diff options
Diffstat (limited to 'new-luxc/source')
53 files changed, 4477 insertions, 4543 deletions
diff --git a/new-luxc/source/luxc/io.jvm.lux b/new-luxc/source/luxc/io.jvm.lux index 21c3da256..d0e09a5b9 100644 --- a/new-luxc/source/luxc/io.jvm.lux +++ b/new-luxc/source/luxc/io.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -13,7 +13,7 @@ (world [file #+ File] [blob #+ Blob]))) -(host;import java.lang.String +(host.import java/lang/String (new [(Array byte)])) (def: host-extension Text ".jvm") @@ -23,38 +23,38 @@ (exception: #export Module-Not-Found) (exception: #export Could-Not-Read-All-Data) -(host;import #long java.io.File +(host.import #long java/io/File (new [String]) (exists [] #io #try boolean) (mkdir [] #io #try boolean) (delete [] #io #try boolean) (length [] #io #try long) - (listFiles [] #io #try (Array java.io.File)) + (listFiles [] #io #try (Array java/io/File)) (getAbsolutePath [] #io #try String) (isFile [] #io #try boolean) (isDirectory [] #io #try boolean)) -(host;import java.lang.AutoCloseable +(host.import java/lang/AutoCloseable (close [] #io #try void)) -(host;import java.io.InputStream +(host.import java/io/InputStream (read [(Array byte)] #io #try int)) -(host;import java.io.FileInputStream - (new [java.io.File] #io #try)) +(host.import java/io/FileInputStream + (new [java/io/File] #io #try)) (def: file-exists? (-> File (Process Bool)) - (|>. java.io.File.new (java.io.File.exists []))) + (|>> java/io/File::new (java/io/File::exists []))) (def: (find-source path dirs) (-> Text (List File) (Process [Text File])) (case dirs - #;Nil - (io;fail (File-Not-Found path)) + #.Nil + (io.fail (File-Not-Found path)) - (#;Cons dir dirs') - (do io;Monad<Process> + (#.Cons dir dirs') + (do io.Monad<Process> [#let [file (format dir "/" path)] ? (file-exists? file)] (if ? @@ -63,44 +63,44 @@ (def: (either left right) (All [a] (-> (Process a) (Process a) (Process a))) - (do io;Monad<IO> + (do io.Monad<IO> [?output left] (case ?output - (#e;Success output) - (wrap (#e;Success output)) + (#e.Success output) + (wrap (#e.Success output)) - (#e;Error error) + (#e.Error error) right))) (def: #export (read-file file) (-> File (Process Blob)) - (do io;Monad<Process> - [#let [file' (java.io.File.new file)] - size (java.io.File.length [] file') - #let [data (blob;create (int-to-nat size))] - stream (FileInputStream.new [file']) - bytes-read (InputStream.read [data] stream) - _ (AutoCloseable.close [] stream)] - (if (i.= size bytes-read) + (do io.Monad<Process> + [#let [file' (java/io/File::new file)] + size (java/io/File::length [] file') + #let [data (blob.create (int-to-nat size))] + stream (FileInputStream::new [file']) + bytes-read (InputStream::read [data] stream) + _ (AutoCloseable::close [] stream)] + (if (i/= size bytes-read) (wrap data) - (io;fail (Could-Not-Read-All-Data file))))) + (io.fail (Could-Not-Read-All-Data file))))) (def: #export (read-module dirs name) (-> (List File) Text (Process [File Text])) (let [host-path (format name host-extension lux-extension) lux-path (format name lux-extension)] - (do io;Monad<Process> + (do io.Monad<Process> [[path file] (: (Process [Text File]) ($_ either (find-source host-path dirs) (find-source lux-path dirs) - (io;fail (Module-Not-Found name)))) + (io.fail (Module-Not-Found name)))) blob (read-file file)] - (wrap [path (String.new blob)])))) + (wrap [path (String::new blob)])))) (def: #export (write-module name descriptor) - (-> Text Text (T;Task Unit)) - (T;fail "'write-module' is undefined.")) + (-> Text Text (T.Task Unit)) + (T.fail "'write-module' is undefined.")) (def: (platform-target root-target) (-> File File) @@ -108,20 +108,20 @@ "JS" "js"}))) (def: #export (prepare-target target-dir) - (-> File (T;Task Unit)) - (do T;Monad<Task> - [_ (file;make-dir target-dir) - _ (file;make-dir (platform-target target-dir))] + (-> File (T.Task Unit)) + (do T.Monad<Task> + [_ (file.make-dir target-dir) + _ (file.make-dir (platform-target target-dir))] (wrap []))) (def: #export (prepare-module target-dir module-name) - (-> File Text (T;Task Unit)) - (do T;Monad<Task> - [_ (file;make-dir (format (platform-target target-dir) "/" module-name))] + (-> File Text (T.Task Unit)) + (do T.Monad<Task> + [_ (file.make-dir (format (platform-target target-dir) "/" module-name))] (wrap []))) (def: #export (write-file target-dir file-name content) - (-> File Text Blob (T;Task Unit)) + (-> File Text Blob (T.Task Unit)) (|> file-name (format (platform-target target-dir) "/") - (file;write content))) + (file.write content))) diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux index b85409fb9..5a00794f8 100644 --- a/new-luxc/source/luxc/lang.lux +++ b/new-luxc/source/luxc/lang.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -17,59 +17,59 @@ (-> Type Code (Meta Top))) (type: #export Analyser - (-> Code (Meta la;Analysis))) + (-> Code (Meta la.Analysis))) (def: #export version Text "0.6.0") (def: #export (fail message) (All [a] (-> Text (Meta a))) - (do macro;Monad<Meta> - [[file line col] macro;cursor + (do macro.Monad<Meta> + [[file line col] macro.cursor #let [location (format file "," (|> line nat-to-int %i) "," (|> col nat-to-int %i))]] - (macro;fail (format message "\n\n" + (macro.fail (format message "\n\n" "@ " location)))) (def: #export (throw exception message) - (All [a] (-> ex;Exception Text (Meta a))) + (All [a] (-> ex.Exception Text (Meta a))) (fail (exception message))) (syntax: #export (assert exception message test) (wrap (list (` (if (~ test) - (:: macro;Monad<Meta> (~' wrap) []) - (;;throw (~ exception) (~ message))))))) + (:: macro.Monad<Meta> (~' wrap) []) + (..throw (~ exception) (~ message))))))) (def: #export (with-type expected action) (All [a] (-> Type (Meta a) (Meta a))) (function [compiler] - (case (action (set@ #;expected (#;Some expected) compiler)) - (#e;Success [compiler' output]) - (let [old-expected (get@ #;expected compiler)] - (#e;Success [(set@ #;expected old-expected compiler') + (case (action (set@ #.expected (#.Some expected) compiler)) + (#e.Success [compiler' output]) + (let [old-expected (get@ #.expected compiler)] + (#e.Success [(set@ #.expected old-expected compiler') output])) - (#e;Error error) - (#e;Error error)))) + (#e.Error error) + (#e.Error error)))) (def: #export (with-type-env action) - (All [a] (-> (tc;Check a) (Meta a))) + (All [a] (-> (tc.Check a) (Meta a))) (function [compiler] - (case (action (get@ #;type-context compiler)) - (#e;Error error) + (case (action (get@ #.type-context compiler)) + (#e.Error error) ((fail error) compiler) - (#e;Success [context' output]) - (#e;Success [(set@ #;type-context context' compiler) + (#e.Success [context' output]) + (#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') + (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 @@ -77,133 +77,133 @@ (def: #export (infer actualT) (-> Type (Meta Unit)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] + (do macro.Monad<Meta> + [expectedT macro.expected-type] (with-type-env - (tc;check expectedT actualT)))) + (tc.check expectedT actualT)))) (def: #export (pl-get key table) (All [a] (-> Text (List [Text a]) (Maybe a))) (case table - #;Nil - #;None + #.Nil + #.None - (#;Cons [k' v'] table') + (#.Cons [k' v'] table') (if (text/= key k') - (#;Some v') + (#.Some v') (pl-get key table')))) (def: #export (pl-contains? key table) (All [a] (-> Text (List [Text a]) Bool)) (case (pl-get key table) - (#;Some _) + (#.Some _) true - #;None + #.None false)) (def: #export (pl-put key val table) (All [a] (-> Text a (List [Text a]) (List [Text a]))) (case table - #;Nil + #.Nil (list [key val]) - (#;Cons [k' v'] table') + (#.Cons [k' v'] table') (if (text/= key k') - (#;Cons [key val] + (#.Cons [key val] table') - (#;Cons [k' v'] + (#.Cons [k' v'] (pl-put key val table'))))) (def: #export (pl-update key f table) (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a]))) (case table - #;Nil - #;Nil + #.Nil + #.Nil - (#;Cons [k' v'] table') + (#.Cons [k' v'] table') (if (text/= key k') - (#;Cons [k' (f v')] table') - (#;Cons [k' v'] (pl-update key f table'))))) + (#.Cons [k' (f v')] table') + (#.Cons [k' v'] (pl-update key f table'))))) (def: #export (with-source-code source action) (All [a] (-> Source (Meta a) (Meta a))) (function [compiler] - (let [old-source (get@ #;source compiler)] - (case (action (set@ #;source source compiler)) - (#e;Error error) - (#e;Error error) + (let [old-source (get@ #.source compiler)] + (case (action (set@ #.source source compiler)) + (#e.Error error) + (#e.Error error) - (#e;Success [compiler' output]) - (#e;Success [(set@ #;source old-source compiler') + (#e.Success [compiler' output]) + (#e.Success [(set@ #.source old-source compiler') output]))))) (def: #export (with-stacked-errors handler action) (All [a] (-> (-> [] Text) (Meta a) (Meta a))) (function [compiler] (case (action compiler) - (#e;Success [compiler' output]) - (#e;Success [compiler' output]) + (#e.Success [compiler' output]) + (#e.Success [compiler' output]) - (#e;Error error) - (#e;Error (if (text/= "" error) + (#e.Error error) + (#e.Error (if (text/= "" error) (handler []) (format (handler []) "\n\n-----------------------------------------\n\n" error)))))) (def: fresh-bindings (All [k v] (Bindings k v)) - {#;counter +0 - #;mappings (list)}) + {#.counter +0 + #.mappings (list)}) (def: fresh-scope Scope - {#;name (list) - #;inner +0 - #;locals fresh-bindings - #;captured fresh-bindings}) + {#.name (list) + #.inner +0 + #.locals fresh-bindings + #.captured fresh-bindings}) (def: #export (with-scope action) (All [a] (-> (Meta a) (Meta [Scope a]))) (function [compiler] - (case (action (update@ #;scopes (|>. (#;Cons fresh-scope)) compiler)) - (#e;Success [compiler' output]) - (case (get@ #;scopes compiler') - #;Nil - (#e;Error "Impossible error: Drained scopes!") - - (#;Cons head tail) - (#e;Success [(set@ #;scopes tail compiler') + (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)) + (#e.Success [compiler' output]) + (case (get@ #.scopes compiler') + #.Nil + (#e.Error "Impossible error: Drained scopes!") + + (#.Cons head tail) + (#e.Success [(set@ #.scopes tail compiler') [head output]])) - (#e;Error error) - (#e;Error error)))) + (#e.Error error) + (#e.Error error)))) (def: #export (with-current-module name action) (All [a] (-> Text (Meta a) (Meta a))) (function [compiler] - (case (action (set@ #;current-module (#;Some name) compiler)) - (#e;Success [compiler' output]) - (#e;Success [(set@ #;current-module - (get@ #;current-module compiler) + (case (action (set@ #.current-module (#.Some name) compiler)) + (#e.Success [compiler' output]) + (#e.Success [(set@ #.current-module + (get@ #.current-module compiler) compiler') output]) - (#e;Error error) - (#e;Error error)))) + (#e.Error error) + (#e.Error error)))) (def: #export (with-cursor cursor action) (All [a] (-> Cursor (Meta a) (Meta a))) - (if (text/= "" (product;left cursor)) + (if (text/= "" (product.left cursor)) action (function [compiler] - (let [old-cursor (get@ #;cursor compiler)] - (case (action (set@ #;cursor cursor compiler)) - (#e;Success [compiler' output]) - (#e;Success [(set@ #;cursor old-cursor compiler') + (let [old-cursor (get@ #.cursor compiler)] + (case (action (set@ #.cursor cursor compiler)) + (#e.Success [compiler' output]) + (#e.Success [(set@ #.cursor old-cursor compiler') output]) - (#e;Error error) - (#e;Error error)))))) + (#e.Error error) + (#e.Error error)))))) (def: (normalize-char char) (-> Nat Text) @@ -232,17 +232,17 @@ (^ (char "~")) "_TILDE_" (^ (char "|")) "_PIPE_" _ - (text;from-code char))) + (text.from-code char))) -(def: underflow Nat (n.dec +0)) +(def: underflow Nat (n/dec +0)) (def: #export (normalize-name name) (-> Text Text) - (loop [idx (n.dec (text;size name)) + (loop [idx (n/dec (text.size name)) output ""] - (if (n.= underflow idx) + (if (n/= underflow idx) output - (recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output))))) + (recur (n/dec idx) (format (|> (text.nth idx name) maybe.assume normalize-char) output))))) (exception: #export Error) @@ -250,7 +250,7 @@ (All [a] (-> (Meta a) (Meta a))) (function [compiler] (case (action compiler) - (#e;Error error) + (#e.Error error) ((throw Error error) compiler) output diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index f6163feb1..107d4979e 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -1,9 +1,9 @@ -(;module: +(.module: lux (lux [function] (data (coll [list "list/" Fold<List>])) (macro [code])) - (luxc (lang [";L" variable #+ Variable]))) + (luxc (lang [".L" variable #+ Variable]))) (type: #export Pattern Code) @@ -28,23 +28,23 @@ (def: #export (sum tag size temp value) (-> Nat Nat Nat Analysis Analysis) - (if (n.= (n.dec size) tag) - (if (n.= +1 tag) + (if (n/= (n/dec size) tag) + (if (n/= +1 tag) (sum-right value) - (list/fold (function;const sum-left) + (list/fold (function.const sum-left) (sum-right value) - (list;n.range +0 (n.- +2 tag)))) - (list/fold (function;const sum-left) + (list.n/range +0 (n/- +2 tag)))) + (list/fold (function.const sum-left) (case value (^or (^code ("lux sum left" (~ inner))) (^code ("lux sum right" (~ inner)))) (` ("lux case" (~ value) - {("lux case bind" (~ (code;nat temp))) - ((~ (code;int (local-variable temp))))})) + {("lux case bind" (~ (code.nat temp))) + ((~ (code.int (local-variable temp))))})) _ value) - (list;n.range +0 tag)))) + (list.n/range +0 tag)))) ## Tuples get analysed into binary products for the sake of semantic ## simplicity, since products/pairs can encode tuples of any length @@ -53,13 +53,13 @@ (def: #export (product members) (-> (List Analysis) Analysis) (case members - #;Nil + #.Nil (` []) - (#;Cons singleton #;Nil) + (#.Cons singleton #.Nil) singleton - (#;Cons left right) + (#.Cons left right) (` [(~ left) (~ (product right))]))) ## Function application gets analysed into single-argument @@ -75,17 +75,17 @@ (def: #export (procedure name args) (-> Text (List Analysis) Analysis) - (` ((~ (code;text name)) (~@ args)))) + (` ((~ (code.text name)) (~@ args)))) (def: #export (var idx) (-> Variable Analysis) - (` ((~ (code;int idx))))) + (` ((~ (code.int idx))))) (def: #export (unfold-tuple analysis) (-> Analysis (List Analysis)) (case analysis (^code [(~ left) (~ right)]) - (#;Cons left (unfold-tuple right)) + (#.Cons left (unfold-tuple right)) _ (list analysis))) @@ -99,13 +99,13 @@ (case valueA (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) - (recur (n.inc so-far) valueA) + (recur (n/inc so-far) valueA) _ - (#;Some [so-far false valueA])) + (#.Some [so-far false valueA])) (^code ("lux sum right" (~ valueA))) - (#;Some [(n.inc so-far) true valueA]) + (#.Some [(n/inc so-far) true valueA]) _ - #;None))) + #.None))) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index 949e18a26..16f775907 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -16,11 +16,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] + (lang ["&." scope] ["la" analysis] - (analysis [";A" common] - [";A" structure] - (case [";A" coverage]))))) + (analysis [".A" common] + [".A" structure] + (case [".A" coverage]))))) (exception: #export Cannot-Match-Type-With-Pattern) (exception: #export Sum-Type-Has-No-Case) @@ -38,11 +38,11 @@ (def: (re-quantify envs baseT) (-> (List (List Type)) Type Type) (case envs - #;Nil + #.Nil baseT - (#;Cons head tail) - (re-quantify tail (#;UnivQ head baseT)))) + (#.Cons head tail) + (re-quantify tail (#.UnivQ head baseT)))) ## Type-checking on the input value is done during the analysis of a ## "case" expression, to ensure that the patterns being used make @@ -57,70 +57,70 @@ (list)) caseT caseT] (case caseT - (#;Var id) - (do macro;Monad<Meta> - [?caseT' (&;with-type-env - (tc;read id))] + (#.Var id) + (do macro.Monad<Meta> + [?caseT' (&.with-type-env + (tc.read id))] (case ?caseT' - (#;Some caseT') + (#.Some caseT') (recur envs caseT') _ - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) - (#;Named name unnamedT) + (#.Named name unnamedT) (recur envs unnamedT) - (#;UnivQ env unquantifiedT) - (recur (#;Cons env envs) unquantifiedT) + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) ## (^template [<tag> <instancer>] ## (<tag> _) - ## (do macro;Monad<Meta> - ## [[_ instanceT] (&;with-type-env + ## (do macro.Monad<Meta> + ## [[_ instanceT] (&.with-type-env ## <instancer>)] - ## (recur (maybe;assume (type;apply (list instanceT) caseT))))) - ## ([#;UnivQ tc;var] - ## [#;ExQ tc;existential]) + ## (recur (maybe.assume (type.apply (list instanceT) caseT))))) + ## ([#.UnivQ tc.var] + ## [#.ExQ tc.existential]) - (#;ExQ _) - (do macro;Monad<Meta> - [[ex-id exT] (&;with-type-env - tc;existential)] - (recur envs (maybe;assume (type;apply (list exT) caseT)))) + (#.ExQ _) + (do macro.Monad<Meta> + [[ex-id exT] (&.with-type-env + tc.existential)] + (recur envs (maybe.assume (type.apply (list exT) caseT)))) - (#;Apply inputT funcT) + (#.Apply inputT funcT) (case funcT - (#;Var funcT-id) - (do macro;Monad<Meta> - [funcT' (&;with-type-env - (do tc;Monad<Check> - [?funct' (tc;read funcT-id)] + (#.Var funcT-id) + (do macro.Monad<Meta> + [funcT' (&.with-type-env + (do tc.Monad<Check> + [?funct' (tc.read funcT-id)] (case ?funct' - (#;Some funct') + (#.Some funct') (wrap funct') _ - (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] - (recur envs (#;Apply inputT funcT'))) + (tc.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] + (recur envs (#.Apply inputT funcT'))) _ - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (recur envs outputT) - #;None - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + #.None + (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) - (#;Product _) + (#.Product _) (|> caseT - type;flatten-tuple + type.flatten-tuple (list/map (re-quantify envs)) - type;tuple - (:: macro;Monad<Meta> wrap)) + type.tuple + (:: macro.Monad<Meta> wrap)) _ - (:: macro;Monad<Meta> wrap (re-quantify envs caseT))))) + (:: macro.Monad<Meta> wrap (re-quantify envs caseT))))) ## This function handles several concerns at once, but it must be that ## way because those concerns are interleaved when doing @@ -139,169 +139,169 @@ ## That is why the body must be analysed in the context of the ## pattern, and not separately. (def: (analyse-pattern num-tags inputT pattern next) - (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) + (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) (case pattern - [cursor (#;Symbol ["" name])] - (&;with-cursor cursor - (do macro;Monad<Meta> - [outputA (&scope;with-local [name inputT] + [cursor (#.Symbol ["" name])] + (&.with-cursor cursor + (do macro.Monad<Meta> + [outputA (&scope.with-local [name inputT] next) - idx &scope;next-local] - (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA]))) + idx &scope.next-local] + (wrap [(` ("lux case bind" (~ (code.nat idx)))) outputA]))) - [cursor (#;Symbol ident)] - (&;with-cursor cursor - (&;throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident))) + [cursor (#.Symbol ident)] + (&.with-cursor cursor + (&.throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident))) (^template [<type> <code-tag>] [cursor (<code-tag> test)] - (&;with-cursor cursor - (do macro;Monad<Meta> - [_ (&;with-type-env - (tc;check inputT <type>)) + (&.with-cursor cursor + (do macro.Monad<Meta> + [_ (&.with-type-env + (tc.check inputT <type>)) outputA next] (wrap [pattern outputA])))) - ([Bool #;Bool] - [Nat #;Nat] - [Int #;Int] - [Deg #;Deg] - [Frac #;Frac] - [Text #;Text]) - - (^ [cursor (#;Tuple (list))]) - (&;with-cursor cursor - (do macro;Monad<Meta> - [_ (&;with-type-env - (tc;check inputT Unit)) + ([Bool #.Bool] + [Nat #.Nat] + [Int #.Int] + [Deg #.Deg] + [Frac #.Frac] + [Text #.Text]) + + (^ [cursor (#.Tuple (list))]) + (&.with-cursor cursor + (do macro.Monad<Meta> + [_ (&.with-type-env + (tc.check inputT Unit)) outputA next] (wrap [(` ("lux case tuple" [])) outputA]))) - (^ [cursor (#;Tuple (list singleton))]) - (analyse-pattern #;None inputT singleton next) + (^ [cursor (#.Tuple (list singleton))]) + (analyse-pattern #.None inputT singleton next) - [cursor (#;Tuple sub-patterns)] - (&;with-cursor cursor - (do macro;Monad<Meta> + [cursor (#.Tuple sub-patterns)] + (&.with-cursor cursor + (do macro.Monad<Meta> [inputT' (simplify-case-type inputT)] (case inputT' - (#;Product _) - (let [sub-types (type;flatten-tuple inputT') - num-sub-types (maybe;default (list;size sub-types) + (#.Product _) + (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) - matches (cond (n.< num-sub-types num-sub-patterns) - (let [[prefix suffix] (list;split (n.dec num-sub-patterns) sub-types)] - (list;zip2 (list/compose prefix (list (type;tuple suffix))) sub-patterns)) - - (n.> num-sub-types num-sub-patterns) - (let [[prefix suffix] (list;split (n.dec num-sub-types) sub-patterns)] - (list;zip2 sub-types (list/compose prefix (list (code;tuple suffix))))) + num-sub-patterns (list.size sub-patterns) + matches (cond (n/< num-sub-types num-sub-patterns) + (let [[prefix suffix] (list.split (n/dec num-sub-patterns) sub-types)] + (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) + + (n/> num-sub-types num-sub-patterns) + (let [[prefix suffix] (list.split (n/dec num-sub-types) sub-patterns)] + (list.zip2 sub-types (list/compose prefix (list (code.tuple suffix))))) - ## (n.= num-sub-types num-sub-patterns) - (list;zip2 sub-types sub-patterns) + ## (n/= num-sub-types num-sub-patterns) + (list.zip2 sub-types sub-patterns) )] (do @ [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Meta [(List la;Pattern) a]) - (Meta [(List la;Pattern) a]))) + (-> [Type Code] (Meta [(List la.Pattern) a]) + (Meta [(List la.Pattern) a]))) (function [[memberT memberC] then] (do @ - [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) + [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) analyse-pattern) - #;None memberT memberC then)] + #.None memberT memberC then)] (wrap [(list& memberP memberP+) thenA])))) (do @ [nextA next] (wrap [(list) nextA])) - (list;reverse matches))] + (list.reverse matches))] (wrap [(` ("lux case tuple" [(~@ memberP+)])) thenA]))) _ - (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)) + (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)) ))) - [cursor (#;Record record)] - (do macro;Monad<Meta> - [record (structureA;normalize record) - [members recordT] (structureA;order record) - _ (&;with-type-env - (tc;check inputT recordT))] - (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next)) - - [cursor (#;Tag tag)] - (&;with-cursor cursor - (analyse-pattern #;None inputT (` ((~ pattern))) next)) - - (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))]) - (&;with-cursor cursor - (do macro;Monad<Meta> + [cursor (#.Record record)] + (do macro.Monad<Meta> + [record (structureA.normalize record) + [members recordT] (structureA.order record) + _ (&.with-type-env + (tc.check inputT recordT))] + (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next)) + + [cursor (#.Tag tag)] + (&.with-cursor cursor + (analyse-pattern #.None inputT (` ((~ pattern))) next)) + + (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) + (&.with-cursor cursor + (do macro.Monad<Meta> [inputT' (simplify-case-type inputT)] (case inputT' - (#;Sum _) - (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) - (^multi (#;Some case-type) - (n.< num-cases idx)) - (if (and (n.> num-cases size-sum) - (n.= (n.dec num-cases) idx)) - (do macro;Monad<Meta> - [[testP nextA] (analyse-pattern #;None - (type;variant (list;drop (n.dec num-cases) flat-sum)) + (#.Sum _) + (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) + (^multi (#.Some case-type) + (n/< num-cases idx)) + (if (and (n/> num-cases size-sum) + (n/= (n/dec num-cases) idx)) + (do macro.Monad<Meta> + [[testP nextA] (analyse-pattern #.None + (type.variant (list.drop (n/dec num-cases) flat-sum)) (` [(~@ values)]) next)] - (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) + (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP))) nextA])) - (do macro;Monad<Meta> - [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)] - (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) + (do macro.Monad<Meta> + [[testP nextA] (analyse-pattern #.None case-type (` [(~@ values)]) next)] + (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP))) nextA]))) _ - (&;throw Sum-Type-Has-No-Case + (&.throw Sum-Type-Has-No-Case (format "Case: " (%n idx) "\n" "Type: " (%type inputT))))) _ - (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))))) + (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))))) - (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) - (&;with-cursor cursor - (do macro;Monad<Meta> - [tag (macro;normalize tag) - [idx group variantT] (macro;resolve-tag tag) - _ (&;with-type-env - (tc;check inputT variantT))] - (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (&.with-cursor cursor + (do macro.Monad<Meta> + [tag (macro.normalize tag) + [idx group variantT] (macro.resolve-tag tag) + _ (&.with-type-env + (tc.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~@ values))) next))) _ - (&;throw Unrecognized-Pattern-Syntax (%code pattern)) + (&.throw Unrecognized-Pattern-Syntax (%code pattern)) )) (def: #export (analyse-case analyse inputC branches) - (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) + (-> &.Analyser Code (List [Code Code]) (Meta la.Analysis)) (case branches - #;Nil - (&;throw Cannot-Have-Empty-Branches "") + #.Nil + (&.throw Cannot-Have-Empty-Branches "") - (#;Cons [patternH bodyH] branchesT) - (do macro;Monad<Meta> - [[inputT inputA] (commonA;with-unknown-type + (#.Cons [patternH bodyH] branchesT) + (do macro.Monad<Meta> + [[inputT inputA] (commonA.with-unknown-type (analyse inputC)) - outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) - outputT (monad;map @ + outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) + outputT (monad.map @ (function [[patternT bodyT]] - (analyse-pattern #;None inputT patternT (analyse bodyT))) + (analyse-pattern #.None inputT patternT (analyse bodyT))) branchesT) - outputHC (|> outputH product;left coverageA;determine) - outputTC (monad;map @ (|>. product;left coverageA;determine) outputT) - _ (case (monad;fold e;Monad<Error> coverageA;merge outputHC outputTC) - (#e;Success coverage) - (&;assert Non-Exhaustive-Pattern-Matching "" - (coverageA;exhaustive? coverage)) - - (#e;Error error) - (&;fail error))] - (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT))))))))) + outputHC (|> outputH product.left coverageA.determine) + outputTC (monad.map @ (|>> product.left coverageA.determine) outputT) + _ (case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC) + (#e.Success coverage) + (&.assert Non-Exhaustive-Pattern-Matching "" + (coverageA.exhaustive? coverage)) + + (#e.Error error) + (&.fail error))] + (wrap (` ("lux case" (~ inputA) (~ (code.record (list& outputH outputT))))))))) diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux index 283e21d02..5d34387b4 100644 --- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux +++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -45,7 +45,7 @@ (exception: #export Unknown-Pattern) (def: #export (determine pattern) - (-> la;Pattern (Meta Coverage)) + (-> la.Pattern (Meta Coverage)) (case pattern ## Binding amounts to exhaustive coverage because any value can be ## matched that way. @@ -59,14 +59,14 @@ ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. - (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)] - [_ (#;Frac _)] [_ (#;Text _)]) + (^or [_ (#.Nat _)] [_ (#.Int _)] [_ (#.Deg _)] + [_ (#.Frac _)] [_ (#.Text _)]) (macro/wrap #Partial) ## Bools are the exception, since there is only "true" and ## "false", which means it is possible for boolean ## pattern-matching to become exhaustive if complementary parts meet. - [_ (#;Bool value)] + [_ (#.Bool value)] (macro/wrap (#Bool value)) ## Tuple patterns can be exhaustive if there is exhaustiveness for all of @@ -74,11 +74,11 @@ (^code ("lux case tuple" [(~@ subs)])) (loop [subs subs] (case subs - #;Nil + #.Nil (macro/wrap #Exhaustive) - (#;Cons sub subs') - (do macro;Monad<Meta> + (#.Cons sub subs') + (do macro.Monad<Meta> [pre (determine sub) post (recur subs')] (if (exhaustive? post) @@ -87,15 +87,15 @@ ## Variant patterns can be shown to be exhaustive if all the possible ## cases are handled exhaustively. - (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub))) - (do macro;Monad<Meta> + (^code ("lux case variant" (~ [_ (#.Nat tag-id)]) (~ [_ (#.Nat num-tags)]) (~ sub))) + (do macro.Monad<Meta> [=sub (determine sub)] (wrap (#Variant num-tags - (|> (dict;new number;Hash<Nat>) - (dict;put tag-id =sub))))) + (|> (dict.new number.Hash<Nat>) + (dict.put tag-id =sub))))) _ - (&;throw Unknown-Pattern (%code pattern)))) + (&.throw Unknown-Pattern (%code pattern)))) (def: (xor left right) (-> Bool Bool Bool) @@ -109,8 +109,8 @@ ## Because of that, the presence of redundant patterns is assumed to ## be a bug, likely due to programmer carelessness. (def: redundant-pattern - (e;Error Coverage) - (e;fail "Redundant pattern.")) + (e.Error Coverage) + (e.fail "Redundant pattern.")) (def: (flatten-alt coverage) (-> Coverage (List Coverage)) @@ -131,8 +131,8 @@ (bool/= sideR sideS) [(#Variant allR casesR) (#Variant allS casesS)] - (and (n.= allR allS) - (:: (dict;Eq<Dict> =) = casesR casesS)) + (and (n/= allR allS) + (:: (dict.Eq<Dict> =) = casesR casesS)) [(#Seq leftR rightR) (#Seq leftS rightS)] (and (= leftR leftS) @@ -141,10 +141,10 @@ [(#Alt _) (#Alt _)] (let [flatR (flatten-alt reference) flatS (flatten-alt sample)] - (and (n.= (list;size flatR) (list;size flatS)) - (list;every? (function [[coverageR coverageS]] + (and (n/= (list.size flatR) (list.size flatS)) + (list.every? (function [[coverageR coverageS]] (= coverageR coverageS)) - (list;zip2 flatR flatS)))) + (list.zip2 flatR flatS)))) _ false))) @@ -156,7 +156,7 @@ ## pattern-matching expression is exhaustive and whether it contains ## redundant patterns. (def: #export (merge addition so-far) - (-> Coverage Coverage (e;Error Coverage)) + (-> Coverage Coverage (e.Error Coverage)) (case [addition so-far] ## The addition cannot possibly improve the coverage. [_ #Exhaustive] @@ -175,28 +175,28 @@ (error/wrap #Exhaustive) [(#Variant allA casesA) (#Variant allSF casesSF)] - (cond (not (n.= allSF allA)) - (e;fail "Variants do not match.") + (cond (not (n/= allSF allA)) + (e.fail "Variants do not match.") - (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA) + (:: (dict.Eq<Dict> Eq<Coverage>) = casesSF casesA) redundant-pattern ## else - (do e;Monad<Error> - [casesM (monad;fold @ + (do e.Monad<Error> + [casesM (monad.fold @ (function [[tagA coverageA] casesSF'] - (case (dict;get tagA casesSF') - (#;Some coverageSF) + (case (dict.get tagA casesSF') + (#.Some coverageSF) (do @ [coverageM (merge coverageA coverageSF)] - (wrap (dict;put tagA coverageM casesSF'))) - - #;None - (wrap (dict;put tagA coverageA casesSF')))) - casesSF (dict;entries casesA))] - (wrap (if (let [case-coverages (dict;values casesM)] - (and (n.= allSF (list;size case-coverages)) - (list;every? exhaustive? case-coverages))) + (wrap (dict.put tagA coverageM casesSF'))) + + #.None + (wrap (dict.put tagA coverageA casesSF')))) + casesSF (dict.entries casesA))] + (wrap (if (let [case-coverages (dict.values casesM)] + (and (n/= allSF (list.size case-coverages)) + (list.every? exhaustive? case-coverages))) #Exhaustive (#Variant allSF casesM))))) @@ -212,7 +212,7 @@ ## Same prefix [true false] - (do e;Monad<Error> + (do e.Monad<Error> [rightM (merge rightA rightSF)] (if (exhaustive? rightM) ## If all that follows is exhaustive, then it can be safely dropped @@ -223,7 +223,7 @@ ## Same suffix [false true] - (do e;Monad<Error> + (do e.Monad<Error> [leftM (merge leftA leftSF)] (wrap (#Seq leftM rightA)))) @@ -247,48 +247,48 @@ ## This process must be repeated until no further productive ## merges can be done. [_ (#Alt leftS rightS)] - (do e;Monad<Error> + (do e.Monad<Error> [#let [fuse-once (: (-> Coverage (List Coverage) - (e;Error [(Maybe Coverage) + (e.Error [(Maybe Coverage) (List Coverage)])) (function [coverage possibilities] (loop [alts possibilities] (case alts - #;Nil - (wrap [#;None (list coverage)]) + #.Nil + (wrap [#.None (list coverage)]) - (#;Cons alt alts') + (#.Cons alt alts') (case (merge coverage alt) - (#e;Success altM) + (#e.Success altM) (case altM (#Alt _) (do @ [[success alts+] (recur alts')] - (wrap [success (#;Cons alt alts+)])) + (wrap [success (#.Cons alt alts+)])) _ - (wrap [(#;Some altM) alts'])) + (wrap [(#.Some altM) alts'])) - (#e;Error error) - (e;fail error)) + (#e.Error error) + (e.fail error)) ))))] [success possibilities] (fuse-once addition (flatten-alt so-far))] (loop [success success possibilities possibilities] (case success - (#;Some coverage') + (#.Some coverage') (do @ [[success' possibilities'] (fuse-once coverage' possibilities)] (recur success' possibilities')) - #;None - (case (list;reverse possibilities) - (#;Cons last prevs) + #.None + (case (list.reverse possibilities) + (#.Cons last prevs) (wrap (list/fold (function [left right] (#Alt left right)) last prevs)) - #;Nil + #.Nil (undefined))))) _ diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index c1a2a4f5b..aeed656a8 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -12,18 +12,18 @@ (def: #export (with-unknown-type action) (All [a] (-> (Meta a) (Meta [Type a]))) - (do macro;Monad<Meta> - [[_ varT] (&;with-type-env tc;var) - analysis (&;with-type varT + (do macro.Monad<Meta> + [[_ varT] (&.with-type-env tc.var) + analysis (&.with-type varT action) - knownT (&;with-type-env (tc;clean varT))] + knownT (&.with-type-env (tc.clean varT))] (wrap [knownT analysis]))) (exception: #export Variant-Tag-Out-Of-Bounds) (def: #export (variant-out-of-bounds-error type size tag) (All [a] (-> Type Nat Nat (Meta a))) - (&;throw Variant-Tag-Out-Of-Bounds + (&.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/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index b16499c01..0f3cdcf6e 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -10,94 +10,94 @@ (type ["tc" check])) [host]) (luxc ["&" lang] - (lang ["&;" module] - [";L" host] - [";L" macro] + (lang ["&." module] + [".L" host] + [".L" macro] ["la" analysis] - (translation [";T" common]))) - (// [";A" common] - [";A" function] - [";A" primitive] - [";A" reference] - [";A" structure] - [";A" procedure])) + (translation [".T" common]))) + (// [".A" common] + [".A" function] + [".A" primitive] + [".A" reference] + [".A" structure] + [".A" procedure])) (exception: #export Macro-Expression-Must-Have-Single-Expansion) (exception: #export Unrecognized-Syntax) (exception: #export Macro-Expansion-Failed) (def: #export (analyser eval) - (-> &;Eval &;Analyser) - (: (-> Code (Meta la;Analysis)) + (-> &.Eval &.Analyser) + (: (-> Code (Meta la.Analysis)) (function analyse [code] - (do macro;Monad<Meta> - [expectedT macro;expected-type] + (do macro.Monad<Meta> + [expectedT macro.expected-type] (let [[cursor code'] code] ## The cursor must be set in the compiler for the sake ## of having useful error messages. - (&;with-cursor cursor + (&.with-cursor cursor (case code' (^template [<tag> <analyser>] (<tag> value) (<analyser> value)) - ([#;Bool primitiveA;analyse-bool] - [#;Nat primitiveA;analyse-nat] - [#;Int primitiveA;analyse-int] - [#;Deg primitiveA;analyse-deg] - [#;Frac primitiveA;analyse-frac] - [#;Text primitiveA;analyse-text]) + ([#.Bool primitiveA.analyse-bool] + [#.Nat primitiveA.analyse-nat] + [#.Int primitiveA.analyse-int] + [#.Deg primitiveA.analyse-deg] + [#.Frac primitiveA.analyse-frac] + [#.Text primitiveA.analyse-text]) - (^ (#;Tuple (list))) - primitiveA;analyse-unit + (^ (#.Tuple (list))) + primitiveA.analyse-unit ## Singleton tuples are equivalent to the element they contain. - (^ (#;Tuple (list singleton))) + (^ (#.Tuple (list singleton))) (analyse singleton) - (^ (#;Tuple elems)) - (structureA;analyse-product analyse elems) + (^ (#.Tuple elems)) + (structureA.analyse-product analyse elems) - (^ (#;Record pairs)) - (structureA;analyse-record analyse pairs) + (^ (#.Record pairs)) + (structureA.analyse-record analyse pairs) - (#;Symbol reference) - (referenceA;analyse-reference reference) + (#.Symbol reference) + (referenceA.analyse-reference reference) - (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) - (procedureA;analyse-procedure analyse eval proc-name proc-args) + (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) + (procedureA.analyse-procedure analyse eval proc-name proc-args) (^template [<tag> <analyser>] - (^ (#;Form (list& [_ (<tag> tag)] + (^ (#.Form (list& [_ (<tag> tag)] values))) (case values - (#;Cons value #;Nil) + (#.Cons value #.Nil) (<analyser> analyse tag value) _ (<analyser> analyse tag (` [(~@ values)])))) - ([#;Nat structureA;analyse-sum] - [#;Tag structureA;analyse-tagged-sum]) + ([#.Nat structureA.analyse-sum] + [#.Tag structureA.analyse-tagged-sum]) - (#;Tag tag) - (structureA;analyse-tagged-sum analyse tag (' [])) + (#.Tag tag) + (structureA.analyse-tagged-sum analyse tag (' [])) - (^ (#;Form (list& func args))) - (do macro;Monad<Meta> - [[funcT funcA] (commonA;with-unknown-type + (^ (#.Form (list& func args))) + (do macro.Monad<Meta> + [[funcT funcA] (commonA.with-unknown-type (analyse func))] (case funcA - [_ (#;Symbol def-name)] + [_ (#.Symbol def-name)] (do @ - [?macro (&;with-error-tracking - (macro;find-macro def-name))] + [?macro (&.with-error-tracking + (macro.find-macro def-name))] (case ?macro - (#;Some macro) + (#.Some macro) (do @ [expansion (: (Meta (List Code)) (function [compiler] - (case (macroL;expand macro args compiler) - (#e;Error error) - ((&;throw Macro-Expansion-Failed error) compiler) + (case (macroL.expand macro args compiler) + (#e.Error error) + ((&.throw Macro-Expansion-Failed error) compiler) output output)))] @@ -106,14 +106,14 @@ (analyse single) _ - (&;throw Macro-Expression-Must-Have-Single-Expansion (%code code)))) + (&.throw Macro-Expression-Must-Have-Single-Expansion (%code code)))) _ - (functionA;analyse-apply analyse funcT funcA args))) + (functionA.analyse-apply analyse funcT funcA args))) _ - (functionA;analyse-apply analyse funcT funcA args))) + (functionA.analyse-apply analyse funcT funcA args))) _ - (&;throw Unrecognized-Syntax (%code code)) + (&.throw Unrecognized-Syntax (%code code)) ))))))) diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index b4aa31c90..758acd681 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -11,11 +11,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] + (lang ["&." scope] ["la" analysis #+ Analysis] - (analysis ["&;" common] - ["&;" inference]) - [";L" variable #+ Variable]))) + (analysis ["&." common] + ["&." inference]) + [".L" variable #+ Variable]))) (exception: #export Cannot-Analyse-Function) (exception: #export Invalid-Function-Type) @@ -23,81 +23,81 @@ ## [Analysers] (def: #export (analyse-function analyse func-name arg-name body) - (-> &;Analyser Text Text Code (Meta Analysis)) - (do macro;Monad<Meta> - [functionT macro;expected-type] + (-> &.Analyser Text Text Code (Meta Analysis)) + (do macro.Monad<Meta> + [functionT macro.expected-type] (loop [expectedT functionT] - (&;with-stacked-errors + (&.with-stacked-errors (function [_] (Cannot-Analyse-Function (format " Type: " (%type expectedT) "\n" "Function: " func-name "\n" "Argument: " arg-name "\n" " Body: " (%code body)))) (case expectedT - (#;Named name unnamedT) + (#.Named name unnamedT) (recur unnamedT) - (#;Apply argT funT) - (case (type;apply (list argT) funT) - (#;Some value) + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) (recur value) - #;None - (&;throw Invalid-Function-Type (%type expectedT))) + #.None + (&.throw Invalid-Function-Type (%type expectedT))) (^template [<tag> <instancer>] (<tag> _) (do @ - [[_ instanceT] (&;with-type-env <instancer>)] - (recur (maybe;assume (type;apply (list instanceT) expectedT))))) - ([#;UnivQ tc;existential] - [#;ExQ tc;var]) + [[_ instanceT] (&.with-type-env <instancer>)] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') + (#.Some expectedT') (recur expectedT') _ ## Inference (do @ - [[input-id inputT] (&;with-type-env tc;var) - [output-id outputT] (&;with-type-env tc;var) - #let [funT (#;Function inputT outputT)] + [[input-id inputT] (&.with-type-env tc.var) + [output-id outputT] (&.with-type-env tc.var) + #let [funT (#.Function inputT outputT)] funA (recur funT) - _ (&;with-type-env - (tc;check expectedT funT))] + _ (&.with-type-env + (tc.check expectedT funT))] (wrap funA)) )) - (#;Function inputT outputT) + (#.Function inputT outputT) (<| (:: @ map (function [[scope bodyA]] - (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))] + (` ("lux function" [(~@ (list/map code.int (variableL.environment scope)))] (~ bodyA))))) - &;with-scope + &.with-scope ## Functions have access not only to their argument, but ## also to themselves, through a local variable. - (&scope;with-local [func-name expectedT]) - (&scope;with-local [arg-name inputT]) - (&;with-type outputT) + (&scope.with-local [func-name expectedT]) + (&scope.with-local [arg-name inputT]) + (&.with-type outputT) (analyse body)) _ - (&;fail "") + (&.fail "") ))))) (def: #export (analyse-apply analyse funcT funcA args) - (-> &;Analyser Type Analysis (List Code) (Meta Analysis)) - (&;with-stacked-errors + (-> &.Analyser Type Analysis (List Code) (Meta Analysis)) + (&.with-stacked-errors (function [_] (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" "Arguments:" (|> args - list;enumerate + list.enumerate (list/map (function [[idx argC]] (format "\n " (%n idx) " " (%code argC)))) - (text;join-with ""))))) - (do macro;Monad<Meta> - [[applyT argsA] (&inference;general analyse funcT args)] - (wrap (la;apply argsA funcA))))) + (text.join-with ""))))) + (do macro.Monad<Meta> + [[applyT argsA] (&inference.general 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 e89ab2e1e..881eee4a6 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -11,7 +11,7 @@ (type ["tc" check]))) (luxc ["&" lang] (lang ["la" analysis #+ Analysis] - (analysis ["&;" common])))) + (analysis ["&." common])))) (exception: #export Cannot-Infer) (def: (cannot-infer type args) @@ -19,10 +19,10 @@ (format " Type: " (%type type) "\n" "Arguments:" (|> args - list;enumerate + list.enumerate (list/map (function [[idx argC]] (format "\n " (%n idx) " " (%code argC)))) - (text;join-with "")))) + (text.join-with "")))) (exception: #export Cannot-Infer-Argument) (exception: #export Smaller-Variant-Than-Expected) @@ -33,29 +33,29 @@ (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)) + (#.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]) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) - (#;Bound idx) - (if (n.= bound-idx idx) + (#.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]) + (replace-bound (n/+ +2 bound-idx) replacementT quantified))) + ([#.UnivQ] + [#.ExQ]) _ type)) @@ -68,36 +68,36 @@ ## But, so long as the type being used for the inference can be treated ## as a function type, this method of inference should work. (def: #export (general analyse inferT args) - (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)])) + (-> &.Analyser Type (List Code) (Meta [Type (List Analysis)])) (case args - #;Nil - (do macro;Monad<Meta> - [_ (&;infer inferT)] + #.Nil + (do macro.Monad<Meta> + [_ (&.infer inferT)] (wrap [inferT (list)])) - (#;Cons argC args') + (#.Cons argC args') (case inferT - (#;Named name unnamedT) + (#.Named name unnamedT) (general analyse unnamedT args) - (#;UnivQ _) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] - (general analyse (maybe;assume (type;apply (list varT) inferT)) args)) + (#.UnivQ _) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) - (#;ExQ _) - (do macro;Monad<Meta> - [[ex-id exT] (&;with-type-env - tc;existential)] - (general analyse (maybe;assume (type;apply (list exT) inferT)) args)) + (#.ExQ _) + (do macro.Monad<Meta> + [[ex-id exT] (&.with-type-env + tc.existential)] + (general analyse (maybe.assume (type.apply (list exT) inferT)) args)) - (#;Apply inputT transT) - (case (type;apply (list inputT) transT) - (#;Some outputT) + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) (general analyse outputT args) - #;None - (&;throw Invalid-Type-Application (%type inferT))) + #.None + (&.throw Invalid-Type-Application (%type inferT))) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which @@ -106,59 +106,59 @@ ## By inferring back-to-front, a lot of type-annotations can be ## avoided in Lux code, since the inference algorithm can piece ## things together more easily. - (#;Function inputT outputT) - (do macro;Monad<Meta> + (#.Function inputT outputT) + (do macro.Monad<Meta> [[outputT' args'A] (general analyse outputT args') - argA (&;with-stacked-errors + argA (&.with-stacked-errors (function [_] (Cannot-Infer-Argument (format "Inferred Type: " (%type inputT) "\n" " Argument: " (%code argC)))) - (&;with-type inputT + (&.with-type inputT (analyse argC)))] (wrap [outputT' (list& argA args'A)])) - (#;Var infer-id) - (do macro;Monad<Meta> - [?inferT' (&;with-type-env (tc;read infer-id))] + (#.Var infer-id) + (do macro.Monad<Meta> + [?inferT' (&.with-type-env (tc.read infer-id))] (case ?inferT' - (#;Some inferT') + (#.Some inferT') (general analyse inferT' args) _ - (&;throw Cannot-Infer (cannot-infer inferT args)))) + (&.throw Cannot-Infer (cannot-infer inferT args)))) _ - (&;throw Cannot-Infer (cannot-infer inferT args))) + (&.throw Cannot-Infer (cannot-infer inferT args))) )) ## Turns a record type into the kind of function type suitable for inference. (def: #export (record inferT) (-> Type (Meta Type)) (case inferT - (#;Named name unnamedT) + (#.Named name unnamedT) (record unnamedT) (^template [<tag>] (<tag> env bodyT) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) + ([#.UnivQ] + [#.ExQ]) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (record outputT) - #;None - (&;throw Invalid-Type-Application (%type inferT))) + #.None + (&.throw Invalid-Type-Application (%type inferT))) - (#;Product _) - (macro/wrap (type;function (type;flatten-tuple inferT) inferT)) + (#.Product _) + (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) _ - (&;throw Not-A-Record-Type (%type inferT)))) + (&.throw Not-A-Record-Type (%type inferT)))) ## Turns a variant type into the kind of function type suitable for inference. (def: #export (variant tag expected-size inferT) @@ -166,60 +166,60 @@ (loop [depth +0 currentT inferT] (case currentT - (#;Named name unnamedT) - (do macro;Monad<Meta> + (#.Named name unnamedT) + (do macro.Monad<Meta> [unnamedT+ (recur depth unnamedT)] (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) - (do macro;Monad<Meta> - [bodyT+ (recur (n.inc depth) bodyT)] + (do macro.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) - (macro/wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)] - (type;function (list (replace! caseT)) + ([#.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) + (macro/wrap (if (n/= +0 depth) + (type.function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] + (type.function (list (replace! caseT)) (replace! currentT))))) - #;None - (&common;variant-out-of-bounds-error inferT expected-size tag)) + #.None + (&common.variant-out-of-bounds-error inferT expected-size tag)) - (n.< expected-size actual-size) - (&;throw Smaller-Variant-Than-Expected + (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))] - (macro/wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)] - (type;function (list (replace! caseT)) + (n/= boundary tag) + (let [caseT (type.variant (list.drop boundary cases))] + (macro/wrap (if (n/= +0 depth) + (type.function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] + (type.function (list (replace! caseT)) (replace! currentT)))))) ## else - (&common;variant-out-of-bounds-error inferT expected-size tag))) + (&common.variant-out-of-bounds-error inferT expected-size tag))) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (variant tag expected-size outputT) - #;None - (&;throw Invalid-Type-Application (%type inferT))) + #.None + (&.throw Invalid-Type-Application (%type inferT))) _ - (&;throw Not-A-Variant-Type (%type inferT))))) + (&.throw Not-A-Variant-Type (%type inferT))))) diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux index 9124ca271..8270e7e73 100644 --- a/new-luxc/source/luxc/lang/analysis/primitive.lux +++ b/new-luxc/source/luxc/lang/analysis/primitive.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) [macro] @@ -11,20 +11,20 @@ (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (Meta Analysis)) - (do macro;Monad<Meta> - [_ (&;infer <type>)] + (do macro.Monad<Meta> + [_ (&.infer <type>)] (wrap (<tag> value))))] - [analyse-bool Bool code;bool] - [analyse-nat Nat code;nat] - [analyse-int Int code;int] - [analyse-deg Deg code;deg] - [analyse-frac Frac code;frac] - [analyse-text Text code;text] + [analyse-bool Bool code.bool] + [analyse-nat Nat code.nat] + [analyse-int Int code.int] + [analyse-deg Deg code.deg] + [analyse-frac Frac code.frac] + [analyse-text Text code.text] ) (def: #export analyse-unit (Meta Analysis) - (do macro;Monad<Meta> - [_ (&;infer Unit)] + (do macro.Monad<Meta> + [_ (&.infer Unit)] (wrap (` [])))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux index 4e9843ddd..25e1be335 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -8,19 +8,19 @@ (coll [dict]))) (luxc ["&" lang] (lang ["la" analysis])) - (/ ["/;" common] - ["/;" host])) + (/ ["/." common] + ["/." host])) (exception: #export Unknown-Procedure) (def: procedures - /common;Bundle - (|> /common;procedures - (dict;merge /host;procedures))) + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) (def: #export (analyse-procedure analyse eval proc-name proc-args) - (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis)) - (<| (maybe;default (&;throw Unknown-Procedure (%t proc-name))) - (do maybe;Monad<Maybe> - [proc (dict;get proc-name procedures)] + (-> &.Analyser &.Eval Text (List Code) (Meta la.Analysis)) + (<| (maybe.default (&.throw Unknown-Procedure (%t proc-name))) + (do maybe.Monad<Maybe> + [proc (dict.get proc-name procedures)] (wrap ((proc proc-name) analyse eval proc-args))))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux index f5afca5bf..b003edfa7 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -14,16 +14,16 @@ [io]) (luxc ["&" lang] (lang ["la" analysis] - (analysis ["&;" common] - [";A" function] - [";A" case] - [";A" type])))) + (analysis ["&." common] + [".A" function] + [".A" case] + [".A" type])))) (exception: #export Incorrect-Procedure-Arity) ## [Utils] (type: #export Proc - (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) + (-> &.Analyser &.Eval (List Code) (Meta la.Analysis))) (type: #export Bundle (Dict Text (-> Text Proc))) @@ -31,14 +31,14 @@ (def: #export (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (dict;put name unnamed)) + (dict.put name unnamed)) (def: #export (prefix prefix bundle) (-> Text Bundle Bundle) (|> bundle - dict;entries + dict.entries (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: #export (wrong-arity proc expected actual) (-> Text Nat Nat Text) @@ -48,19 +48,19 @@ (def: (simple proc inputsT+ outputT) (-> Text (List Type) Type Proc) - (let [num-expected (list;size inputsT+)] + (let [num-expected (list.size inputsT+)] (function [analyse eval args] - (let [num-actual (list;size args)] - (if (n.= num-expected num-actual) - (do macro;Monad<Meta> - [_ (&;infer outputT) - argsA (monad;map @ + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do macro.Monad<Meta> + [_ (&.infer outputT) + argsA (monad.map @ (function [[argT argC]] - (&;with-type argT + (&.with-type argT (analyse argC))) - (list;zip2 inputsT+ args))] - (wrap (la;procedure proc argsA))) - (&;throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual))))))) + (list.zip2 inputsT+ args))] + (wrap (la.procedure proc argsA))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual))))))) (def: #export (nullary valueT proc) (-> Type Text Proc) @@ -83,8 +83,8 @@ (def: (lux-is proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((binary varT varT Bool proc) analyse eval args)))) @@ -95,37 +95,37 @@ (function [analyse eval args] (case args (^ (list opC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Either Text varT))) - opA (&;with-type (type (io;IO varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Either Text varT))) + opA (&.with-type (type (io.IO varT)) (analyse opC))] - (wrap (la;procedure proc (list opA)))) + (wrap (la.procedure proc (list opA)))) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) (def: (lux//function proc) (-> Text Proc) (function [analyse eval args] (case args - (^ (list [_ (#;Symbol ["" func-name])] - [_ (#;Symbol ["" arg-name])] + (^ (list [_ (#.Symbol ["" func-name])] + [_ (#.Symbol ["" arg-name])] body)) - (functionA;analyse-function analyse func-name arg-name body) + (functionA.analyse-function analyse func-name arg-name body) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args)))))) (def: (lux//case proc) (-> Text Proc) (function [analyse eval args] (case args - (^ (list input [_ (#;Record branches)])) - (caseA;analyse-case analyse input branches) + (^ (list input [_ (#.Record branches)])) + (caseA.analyse-case analyse input branches) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args)))))) (do-template [<name> <analyser>] [(def: (<name> proc) @@ -136,28 +136,28 @@ (<analyser> analyse eval typeC valueC) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))] + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))] - [lux//check typeA;analyse-check] - [lux//coerce typeA;analyse-coerce]) + [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 macro;Monad<Meta> - [_ (&;infer (type Type)) - valueA (&;with-type Type + (do macro.Monad<Meta> + [_ (&.infer (type Type)) + valueA (&.with-type Type (analyse valueC))] (wrap valueA)) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) (def: lux-procs Bundle - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "is" lux-is) (install "try" lux-try) (install "function" lux//function) @@ -169,7 +169,7 @@ (def: io-procs Bundle (<| (prefix "io") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "log" (unary Text Unit)) (install "error" (unary Text Bottom)) (install "exit" (unary Int Bottom)) @@ -178,7 +178,7 @@ (def: bit-procs Bundle (<| (prefix "bit") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "count" (unary Nat Nat)) (install "and" (binary Nat Nat Nat)) (install "or" (binary Nat Nat Nat)) @@ -191,7 +191,7 @@ (def: nat-procs Bundle (<| (prefix "nat") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Nat Nat Nat)) (install "-" (binary Nat Nat Nat)) (install "*" (binary Nat Nat Nat)) @@ -207,7 +207,7 @@ (def: int-procs Bundle (<| (prefix "int") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Int Int Int)) (install "-" (binary Int Int Int)) (install "*" (binary Int Int Int)) @@ -223,7 +223,7 @@ (def: deg-procs Bundle (<| (prefix "deg") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Deg Deg Deg)) (install "-" (binary Deg Deg Deg)) (install "*" (binary Deg Deg Deg)) @@ -240,7 +240,7 @@ (def: frac-procs Bundle (<| (prefix "frac") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Frac Frac Frac)) (install "-" (binary Frac Frac Frac)) (install "*" (binary Frac Frac Frac)) @@ -262,7 +262,7 @@ (def: text-procs Bundle (<| (prefix "text") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "=" (binary Text Text Bool)) (install "<" (binary Text Text Bool)) (install "concat" (binary Text Text Text)) @@ -280,31 +280,31 @@ (def: (array//get proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) analyse eval args)))) (def: (array//put proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) analyse eval args)))) (def: (array//remove proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((binary (type (Array varT)) Nat (type (Array varT)) proc) analyse eval args)))) (def: array-procs Bundle (<| (prefix "array") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" (unary Nat Array)) (install "get" array//get) (install "put" array//put) @@ -315,7 +315,7 @@ (def: math-procs Bundle (<| (prefix "math") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "cos" (unary Frac Frac)) (install "sin" (unary Frac Frac)) (install "tan" (unary Frac Frac)) @@ -341,36 +341,36 @@ (function [analyse eval args] (case args (^ (list initC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Atom varT))) - initA (&;with-type varT + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Atom varT))) + initA (&.with-type varT (analyse initC))] - (wrap (la;procedure proc (list initA)))) + (wrap (la.procedure proc (list initA)))) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) (def: (atom-read proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((unary (type (Atom varT)) varT proc) analyse eval args)))) (def: (atom//compare-and-swap proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((trinary (type (Atom varT)) varT varT Bool proc) analyse eval args)))) (def: atom-procs Bundle (<| (prefix "atom") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" atom-new) (install "read" atom-read) (install "compare-and-swap" atom//compare-and-swap) @@ -379,25 +379,25 @@ (def: process-procs Bundle (<| (prefix "process") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "concurrency-level" (nullary Nat)) - (install "future" (unary (type (io;IO Top)) Unit)) - (install "schedule" (binary Nat (type (io;IO Top)) Unit)) + (install "future" (unary (type (io.IO Top)) Unit)) + (install "schedule" (binary Nat (type (io.IO Top)) Unit)) ))) (def: #export procedures Bundle (<| (prefix "lux") - (|> (dict;new text;Hash<Text>) - (dict;merge lux-procs) - (dict;merge bit-procs) - (dict;merge nat-procs) - (dict;merge int-procs) - (dict;merge deg-procs) - (dict;merge frac-procs) - (dict;merge text-procs) - (dict;merge array-procs) - (dict;merge math-procs) - (dict;merge atom-procs) - (dict;merge process-procs) - (dict;merge io-procs)))) + (|> (dict.new text.Hash<Text>) + (dict.merge lux-procs) + (dict.merge bit-procs) + (dict.merge nat-procs) + (dict.merge int-procs) + (dict.merge deg-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge array-procs) + (dict.merge math-procs) + (dict.merge atom-procs) + (dict.merge process-procs) + (dict.merge io-procs)))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux index bb388434f..3c29410d0 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- char] (lux (control [monad #+ do] ["p" parser] @@ -21,10 +21,10 @@ (type ["tc" check])) [host]) (luxc ["&" lang] - (lang ["&;" host] + (lang ["&." host] ["la" analysis] - (analysis ["&;" common] - [";A" inference]))) + (analysis ["&." common] + [".A" inference]))) ["@" //common] ) @@ -32,7 +32,7 @@ (def: (wrong-syntax procedure args) (-> Text (List Code) Text) (format "Procedure: " procedure "\n" - "Arguments: " (%code (code;tuple args)))) + "Arguments: " (%code (code.tuple args)))) (exception: #export JVM-Type-Is-Not-Class) @@ -74,7 +74,7 @@ (def: #export null-class Text "#Null") (do-template [<name> <class>] - [(def: #export <name> Type (#;Primitive <class> (list)))] + [(def: #export <name> Type (#.Primitive <class> (list)))] ## Boxes [Boolean "java.lang.Boolean"] @@ -99,52 +99,52 @@ ) (def: conversion-procs - @;Bundle - (<| (@;prefix "convert") - (|> (dict;new text;Hash<Text>) - (@;install "double-to-float" (@;unary Double Float)) - (@;install "double-to-int" (@;unary Double Integer)) - (@;install "double-to-long" (@;unary Double Long)) - (@;install "float-to-double" (@;unary Float Double)) - (@;install "float-to-int" (@;unary Float Integer)) - (@;install "float-to-long" (@;unary Float Long)) - (@;install "int-to-byte" (@;unary Integer Byte)) - (@;install "int-to-char" (@;unary Integer Character)) - (@;install "int-to-double" (@;unary Integer Double)) - (@;install "int-to-float" (@;unary Integer Float)) - (@;install "int-to-long" (@;unary Integer Long)) - (@;install "int-to-short" (@;unary Integer Short)) - (@;install "long-to-double" (@;unary Long Double)) - (@;install "long-to-float" (@;unary Long Float)) - (@;install "long-to-int" (@;unary Long Integer)) - (@;install "long-to-short" (@;unary Long Short)) - (@;install "long-to-byte" (@;unary Long Byte)) - (@;install "char-to-byte" (@;unary Character Byte)) - (@;install "char-to-short" (@;unary Character Short)) - (@;install "char-to-int" (@;unary Character Integer)) - (@;install "char-to-long" (@;unary Character Long)) - (@;install "byte-to-long" (@;unary Byte Long)) - (@;install "short-to-long" (@;unary Short Long)) + @.Bundle + (<| (@.prefix "convert") + (|> (dict.new text.Hash<Text>) + (@.install "double-to-float" (@.unary Double Float)) + (@.install "double-to-int" (@.unary Double Integer)) + (@.install "double-to-long" (@.unary Double Long)) + (@.install "float-to-double" (@.unary Float Double)) + (@.install "float-to-int" (@.unary Float Integer)) + (@.install "float-to-long" (@.unary Float Long)) + (@.install "int-to-byte" (@.unary Integer Byte)) + (@.install "int-to-char" (@.unary Integer Character)) + (@.install "int-to-double" (@.unary Integer Double)) + (@.install "int-to-float" (@.unary Integer Float)) + (@.install "int-to-long" (@.unary Integer Long)) + (@.install "int-to-short" (@.unary Integer Short)) + (@.install "long-to-double" (@.unary Long Double)) + (@.install "long-to-float" (@.unary Long Float)) + (@.install "long-to-int" (@.unary Long Integer)) + (@.install "long-to-short" (@.unary Long Short)) + (@.install "long-to-byte" (@.unary Long Byte)) + (@.install "char-to-byte" (@.unary Character Byte)) + (@.install "char-to-short" (@.unary Character Short)) + (@.install "char-to-int" (@.unary Character Integer)) + (@.install "char-to-long" (@.unary Character Long)) + (@.install "byte-to-long" (@.unary Byte Long)) + (@.install "short-to-long" (@.unary Short Long)) ))) (do-template [<name> <prefix> <type>] [(def: <name> - @;Bundle - (<| (@;prefix <prefix>) - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary <type> <type> <type>)) - (@;install "-" (@;binary <type> <type> <type>)) - (@;install "*" (@;binary <type> <type> <type>)) - (@;install "/" (@;binary <type> <type> <type>)) - (@;install "%" (@;binary <type> <type> <type>)) - (@;install "=" (@;binary <type> <type> Boolean)) - (@;install "<" (@;binary <type> <type> Boolean)) - (@;install "and" (@;binary <type> <type> <type>)) - (@;install "or" (@;binary <type> <type> <type>)) - (@;install "xor" (@;binary <type> <type> <type>)) - (@;install "shl" (@;binary <type> Integer <type>)) - (@;install "shr" (@;binary <type> Integer <type>)) - (@;install "ushr" (@;binary <type> Integer <type>)) + @.Bundle + (<| (@.prefix <prefix>) + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary <type> <type> <type>)) + (@.install "-" (@.binary <type> <type> <type>)) + (@.install "*" (@.binary <type> <type> <type>)) + (@.install "/" (@.binary <type> <type> <type>)) + (@.install "%" (@.binary <type> <type> <type>)) + (@.install "=" (@.binary <type> <type> Boolean)) + (@.install "<" (@.binary <type> <type> Boolean)) + (@.install "and" (@.binary <type> <type> <type>)) + (@.install "or" (@.binary <type> <type> <type>)) + (@.install "xor" (@.binary <type> <type> <type>)) + (@.install "shl" (@.binary <type> Integer <type>)) + (@.install "shr" (@.binary <type> Integer <type>)) + (@.install "ushr" (@.binary <type> Integer <type>)) )))] [int-procs "int" Integer] @@ -153,16 +153,16 @@ (do-template [<name> <prefix> <type>] [(def: <name> - @;Bundle - (<| (@;prefix <prefix>) - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary <type> <type> <type>)) - (@;install "-" (@;binary <type> <type> <type>)) - (@;install "*" (@;binary <type> <type> <type>)) - (@;install "/" (@;binary <type> <type> <type>)) - (@;install "%" (@;binary <type> <type> <type>)) - (@;install "=" (@;binary <type> <type> Boolean)) - (@;install "<" (@;binary <type> <type> Boolean)) + @.Bundle + (<| (@.prefix <prefix>) + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary <type> <type> <type>)) + (@.install "-" (@.binary <type> <type> <type>)) + (@.install "*" (@.binary <type> <type> <type>)) + (@.install "/" (@.binary <type> <type> <type>)) + (@.install "%" (@.binary <type> <type> <type>)) + (@.install "=" (@.binary <type> <type> Boolean)) + (@.install "<" (@.binary <type> <type> Boolean)) )))] [float-procs "float" Float] @@ -170,11 +170,11 @@ ) (def: char-procs - @;Bundle - (<| (@;prefix "char") - (|> (dict;new text;Hash<Text>) - (@;install "=" (@;binary Character Character Boolean)) - (@;install "<" (@;binary Character Character Boolean)) + @.Bundle + (<| (@.prefix "char") + (|> (dict.new text.Hash<Text>) + (@.install "=" (@.binary Character Character Boolean)) + (@.install "<" (@.binary Character Character Boolean)) ))) (def: #export boxes @@ -187,439 +187,439 @@ ["float" "java.lang.Float"] ["double" "java.lang.Double"] ["char" "java.lang.Character"]) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: (array-length proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC)) - (do macro;Monad<Meta> - [_ (&;infer Nat) - [var-id varT] (&;with-type-env tc;var) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [_ (&.infer Nat) + [var-id varT] (&.with-type-env tc.var) + arrayA (&.with-type (type (Array varT)) (analyse arrayC))] - (wrap (la;procedure proc (list arrayA)))) + (wrap (la.procedure proc (list arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (array-new proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list lengthC)) - (do macro;Monad<Meta> - [lengthA (&;with-type Nat + (do macro.Monad<Meta> + [lengthA (&.with-type Nat (analyse lengthC)) - expectedT macro;expected-type + expectedT macro.expected-type [level elem-class] (: (Meta [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (recur outputT level) - #;None - (&;throw Non-Array (%type expectedT))) + #.None + (&.throw Non-Array (%type expectedT))) - (^ (#;Primitive "#Array" (list elemT))) - (recur elemT (n.inc level)) + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (n/inc level)) - (#;Primitive class _) + (#.Primitive class _) (wrap [level class]) _ - (&;throw Non-Array (%type expectedT))))) - _ (if (n.> +0 level) + (&.throw Non-Array (%type expectedT))))) + _ (if (n/> +0 level) (wrap []) - (&;throw Non-Array (%type expectedT)))] - (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA)))) + (&.throw Non-Array (%type expectedT)))] + (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (check-jvm objectT) (-> Type (Meta Text)) (case objectT - (#;Primitive name _) + (#.Primitive name _) (macro/wrap name) - (#;Named name unnamed) + (#.Named name unnamed) (check-jvm unnamed) - (#;Var id) + (#.Var id) (macro/wrap "java.lang.Object") (^template [<tag>] (<tag> env unquantified) (check-jvm unquantified)) - ([#;UnivQ] - [#;ExQ]) + ([#.UnivQ] + [#.ExQ]) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (check-jvm outputT) - #;None - (&;throw Non-Object (%type objectT))) + #.None + (&.throw Non-Object (%type objectT))) _ - (&;throw Non-Object (%type objectT)))) + (&.throw Non-Object (%type objectT)))) (def: (check-object objectT) (-> Type (Meta Text)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [name (check-jvm objectT)] - (if (dict;contains? name boxes) - (&;throw Primitives-Are-Not-Objects name) + (if (dict.contains? name boxes) + (&.throw Primitives-Are-Not-Objects name) (macro/wrap name)))) (def: (box-array-element-type elemT) (-> Type (Meta [Type Text])) (case elemT - (#;Primitive name #;Nil) - (let [boxed-name (|> (dict;get name boxes) - (maybe;default name))] - (macro/wrap [(#;Primitive boxed-name #;Nil) + (#.Primitive name #.Nil) + (let [boxed-name (|> (dict.get name boxes) + (maybe.default name))] + (macro/wrap [(#.Primitive boxed-name #.Nil) boxed-name])) - (#;Primitive name _) - (if (dict;contains? name boxes) - (&;throw Primitives-Cannot-Have-Type-Parameters name) + (#.Primitive name _) + (if (dict.contains? name boxes) + (&.throw Primitives-Cannot-Have-Type-Parameters name) (macro/wrap [elemT name])) _ - (&;throw Invalid-Type-For-Array-Element (%type elemT)))) + (&.throw Invalid-Type-For-Array-Element (%type elemT)))) (def: (array-read proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC idxC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer varT) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer varT) + arrayA (&.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&;with-type-env - (tc;read var-id)) - [elemT elem-class] (box-array-element-type (maybe;default varT ?elemT)) - idxA (&;with-type Nat + ?elemT (&.with-type-env + (tc.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (&.with-type Nat (analyse idxC))] - (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) + (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: (array-write proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC idxC valueC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Array varT))) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Array varT))) + arrayA (&.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&;with-type-env - (tc;read var-id)) - [valueT elem-class] (box-array-element-type (maybe;default varT ?elemT)) - idxA (&;with-type Nat + ?elemT (&.with-type-env + (tc.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (&.with-type Nat (analyse idxC)) - valueA (&;with-type valueT + valueA (&.with-type valueT (analyse valueC))] - (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) + (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: array-procs - @;Bundle - (<| (@;prefix "array") - (|> (dict;new text;Hash<Text>) - (@;install "length" array-length) - (@;install "new" array-new) - (@;install "read" array-read) - (@;install "write" array-write) + @.Bundle + (<| (@.prefix "array") + (|> (dict.new text.Hash<Text>) + (@.install "length" array-length) + (@.install "new" array-new) + (@.install "read" array-read) + (@.install "write" array-write) ))) (def: (object-null proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list)) - (do macro;Monad<Meta> - [expectedT macro;expected-type + (do macro.Monad<Meta> + [expectedT macro.expected-type _ (check-object expectedT)] - (wrap (la;procedure proc (list)))) + (wrap (la.procedure proc (list)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args)))))) (def: (object-null? proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list objectC)) - (do macro;Monad<Meta> - [_ (&;infer Bool) - [objectT objectA] (&common;with-unknown-type + (do macro.Monad<Meta> + [_ (&.infer Bool) + [objectT objectA] (&common.with-unknown-type (analyse objectC)) _ (check-object objectT)] - (wrap (la;procedure proc (list objectA)))) + (wrap (la.procedure proc (list objectA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-synchronized proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list monitorC exprC)) - (do macro;Monad<Meta> - [[monitorT monitorA] (&common;with-unknown-type + (do macro.Monad<Meta> + [[monitorT monitorA] (&common.with-unknown-type (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (la;procedure proc (list monitorA exprA)))) + (wrap (la.procedure proc (list monitorA exprA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) -(host;import java.lang.Object +(host.import java/lang/Object (equals [Object] boolean)) -(host;import java.lang.ClassLoader) +(host.import java/lang/ClassLoader) -(host;import #long java.lang.reflect.Type +(host.import #long java/lang/reflect/Type (getTypeName [] String)) -(host;import java.lang.reflect.GenericArrayType - (getGenericComponentType [] java.lang.reflect.Type)) +(host.import java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) -(host;import java.lang.reflect.ParameterizedType - (getRawType [] java.lang.reflect.Type) - (getActualTypeArguments [] (Array java.lang.reflect.Type))) +(host.import java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.TypeVariable d) +(host.import (java/lang/reflect/TypeVariable d) (getName [] String) - (getBounds [] (Array java.lang.reflect.Type))) + (getBounds [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.WildcardType d) - (getLowerBounds [] (Array java.lang.reflect.Type)) - (getUpperBounds [] (Array java.lang.reflect.Type))) +(host.import (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) -(host;import java.lang.reflect.Modifier +(host.import java/lang/reflect/Modifier (#static isStatic [int] boolean) (#static isFinal [int] boolean) (#static isInterface [int] boolean) (#static isAbstract [int] boolean)) -(host;import java.lang.reflect.Field - (getDeclaringClass [] (java.lang.Class Object)) +(host.import java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) (getModifiers [] int) - (getGenericType [] java.lang.reflect.Type)) + (getGenericType [] java/lang/reflect/Type)) -(host;import java.lang.reflect.Method +(host.import java/lang/reflect/Method (getName [] String) (getModifiers [] int) (getDeclaringClass [] (Class Object)) (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericReturnType [] java.lang.reflect.Type) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.Constructor c) +(host.import (java/lang/reflect/Constructor c) (getModifiers [] int) (getDeclaringClass [] (Class c)) (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(host;import (java.lang.Class c) +(host.import (java/lang/Class c) (getName [] String) (getModifiers [] int) (#static forName [String boolean ClassLoader] #try (Class Object)) (isAssignableFrom [(Class Object)] boolean) (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java.lang.reflect.Type)) - (getGenericSuperclass [] java.lang.reflect.Type) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) (getDeclaredField [String] #try Field) (getConstructors [] (Array (Constructor Object))) (getDeclaredMethods [] (Array Method))) (def: (load-class name) (-> Text (Meta (Class Object))) - (do macro;Monad<Meta> - [class-loader &host;class-loader] - (case (Class.forName [name false class-loader]) - (#e;Success [class]) + (do macro.Monad<Meta> + [class-loader &host.class-loader] + (case (Class::forName [name false class-loader]) + (#e.Success [class]) (wrap class) - (#e;Error error) - (&;throw Unknown-Class name)))) + (#e.Error error) + (&.throw Unknown-Class name)))) (def: (sub-class? super sub) (-> Text Text (Meta Bool)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [super (load-class super) sub (load-class sub)] - (wrap (Class.isAssignableFrom [sub] super)))) + (wrap (Class::isAssignableFrom [sub] super)))) (def: (object-throw proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list exceptionC)) - (do macro;Monad<Meta> - [_ (&;infer Bottom) - [exceptionT exceptionA] (&common;with-unknown-type + (do macro.Monad<Meta> + [_ (&.infer Bottom) + [exceptionT exceptionA] (&common.with-unknown-type (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Meta Unit) (if ? (wrap []) - (&;throw Non-Throwable exception-class)))] - (wrap (la;procedure proc (list exceptionA)))) + (&.throw Non-Throwable exception-class)))] + (wrap (la.procedure proc (list exceptionA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-class proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC)) (case classC - [_ (#;Text class)] - (do macro;Monad<Meta> - [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list))))) + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] - (wrap (la;procedure proc (list (code;text class))))) + (wrap (la.procedure proc (list (code.text class))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-instance? proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC objectC)) (case classC - [_ (#;Text class)] - (do macro;Monad<Meta> - [_ (&;infer Bool) - [objectT objectA] (&common;with-unknown-type + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (&.infer Bool) + [objectT objectA] (&common.with-unknown-type (analyse objectC)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? - (wrap (la;procedure proc (list (code;text class)))) - (&;throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) + (wrap (la.procedure proc (list (code.text class)))) + (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: object-procs - @;Bundle - (<| (@;prefix "object") - (|> (dict;new text;Hash<Text>) - (@;install "null" object-null) - (@;install "null?" object-null?) - (@;install "synchronized" object-synchronized) - (@;install "throw" object-throw) - (@;install "class" object-class) - (@;install "instance?" object-instance?) + @.Bundle + (<| (@.prefix "object") + (|> (dict.new text.Hash<Text>) + (@.install "null" object-null) + (@.install "null?" object-null?) + (@.install "synchronized" object-synchronized) + (@.install "throw" object-throw) + (@.install "class" object-class) + (@.install "instance?" object-instance?) ))) (def: type-descriptor - (-> java.lang.reflect.Type Text) - (java.lang.reflect.Type.getTypeName [])) + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) (def: (java-type-to-class type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (macro/wrap (Class.getName [] (:! Class type))) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) - (host;instance? ParameterizedType type) - (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type))) + (host.instance? ParameterizedType type) + (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) ## else - (&;throw Cannot-Convert-To-Class (type-descriptor type)))) + (&.throw Cannot-Convert-To-Class (type-descriptor type)))) (type: Mappings (Dict Text Type)) -(def: fresh-mappings Mappings (dict;new text;Hash<Text>)) +(def: fresh-mappings Mappings (dict.new text.Hash<Text>)) (def: (java-type-to-lux-type mappings java-type) - (-> Mappings java.lang.reflect.Type (Meta Type)) - (cond (host;instance? TypeVariable java-type) - (let [var-name (TypeVariable.getName [] (:! TypeVariable java-type))] - (case (dict;get var-name mappings) - (#;Some var-type) + (-> Mappings java/lang/reflect/Type (Meta Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] + (case (dict.get var-name mappings) + (#.Some var-type) (macro/wrap var-type) - #;None - (&;throw Unknown-Type-Var var-name))) + #.None + (&.throw Unknown-Type-Var var-name))) - (host;instance? WildcardType java-type) + (host.instance? WildcardType java-type) (let [java-type (:! WildcardType java-type)] - (case [(array;read +0 (WildcardType.getUpperBounds [] java-type)) - (array;read +0 (WildcardType.getLowerBounds [] java-type))] - (^or [(#;Some bound) _] [_ (#;Some bound)]) + (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) + (array.read +0 (WildcardType::getLowerBounds [] java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) (java-type-to-lux-type mappings bound) _ (macro/wrap Top))) - (host;instance? Class java-type) + (host.instance? Class java-type) (let [java-type (:! (Class Object) java-type) - class-name (Class.getName [] java-type)] - (macro/wrap (case (array;size (Class.getTypeParameters [] java-type)) + class-name (Class::getName [] java-type)] + (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) +0 - (#;Primitive class-name (list)) + (#.Primitive class-name (list)) arity - (|> (list;n.range +0 (n.dec arity)) - list;reverse - (list/map (|>. (n.* +2) n.inc #;Bound)) - (#;Primitive class-name) - (type;univ-q arity))))) + (|> (list.n/range +0 (n/dec arity)) + list.reverse + (list/map (|>> (n/* +2) n/inc #.Bound)) + (#.Primitive class-name) + (type.univ-q arity))))) - (host;instance? ParameterizedType java-type) + (host.instance? ParameterizedType java-type) (let [java-type (:! ParameterizedType java-type) - raw (ParameterizedType.getRawType [] java-type)] - (if (host;instance? Class raw) - (do macro;Monad<Meta> + raw (ParameterizedType::getRawType [] java-type)] + (if (host.instance? Class raw) + (do macro.Monad<Meta> [paramsT (|> java-type - (ParameterizedType.getActualTypeArguments []) - array;to-list - (monad;map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw)) + (ParameterizedType::getActualTypeArguments []) + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) paramsT))) - (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) + (&.throw JVM-Type-Is-Not-Class (type-descriptor raw)))) - (host;instance? GenericArrayType java-type) - (do macro;Monad<Meta> + (host.instance? GenericArrayType java-type) + (do macro.Monad<Meta> [innerT (|> (:! GenericArrayType java-type) - (GenericArrayType.getGenericComponentType []) + (GenericArrayType::getGenericComponentType []) (java-type-to-lux-type mappings))] - (wrap (#;Primitive "#Array" (list innerT)))) + (wrap (#.Primitive "#Array" (list innerT)))) ## else - (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) + (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) (type: Direction #In @@ -634,18 +634,18 @@ (def: (correspond-type-params class type) (-> (Class Object) Type (Meta Mappings)) (case type - (#;Primitive name params) - (let [class-name (Class.getName [] class) - class-params (array;to-list (Class.getTypeParameters [] class)) - num-class-params (list;size class-params) - num-type-params (list;size params)] + (#.Primitive name params) + (let [class-name (Class::getName [] class) + class-params (array.to-list (Class::getTypeParameters [] class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] (cond (not (text/= class-name name)) - (&;throw Cannot-Correspond-Type-With-Class + (&.throw Cannot-Correspond-Type-With-Class (format "Class = " class-name "\n" "Type = " (%type type))) - (not (n.= num-class-params num-type-params)) - (&;throw Type-Parameter-Mismatch + (not (n/= num-class-params num-type-params)) + (&.throw Type-Parameter-Mismatch (format "Expected: " (%i (nat-to-int num-class-params)) "\n" " Actual: " (%i (nat-to-int num-type-params)) "\n" " Class: " class-name "\n" @@ -653,28 +653,28 @@ ## else (macro/wrap (|> params - (list;zip2 (list/map (TypeVariable.getName []) class-params)) - (dict;from-list text;Hash<Text>))) + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dict.from-list text.Hash<Text>))) )) _ - (&;throw Non-JVM-Type (%type type)))) + (&.throw Non-JVM-Type (%type type)))) (def: (cast direction to from) (-> Direction Type Type (Meta [Text Type])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [to-name (check-jvm to) from-name (check-jvm from)] - (cond (dict;contains? to-name boxes) - (let [box (maybe;assume (dict;get to-name boxes))] + (cond (dict.contains? to-name boxes) + (let [box (maybe.assume (dict.get to-name boxes))] (if (text/= box from-name) - (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))]) - (&;throw Cannot-Cast (cannot-cast to from)))) + (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))]) + (&.throw Cannot-Cast (cannot-cast to from)))) - (dict;contains? from-name boxes) - (let [box (maybe;assume (dict;get from-name boxes))] + (dict.contains? from-name boxes) + (let [box (maybe.assume (dict.get from-name boxes))] (do @ - [[_ castT] (cast direction to (#;Primitive box (list)))] + [[_ castT] (cast direction to (#.Primitive box (list)))] (wrap [(choose direction to-name from-name) castT]))) (text/= to-name from-name) @@ -687,226 +687,226 @@ (do @ [to-class (load-class to-name) from-class (load-class from-name) - _ (&;assert Cannot-Cast (cannot-cast to from) - (Class.isAssignableFrom [from-class] to-class)) - candiate-parents (monad;map @ + _ (&.assert Cannot-Cast (cannot-cast to from) + (Class::isAssignableFrom [from-class] to-class)) + candiate-parents (monad.map @ (function [java-type] (do @ [class-name (java-type-to-class java-type) class (load-class class-name)] - (wrap [java-type (Class.isAssignableFrom [class] to-class)]))) - (list& (Class.getGenericSuperclass [] from-class) - (array;to-list (Class.getGenericInterfaces [] from-class))))] + (wrap [java-type (Class::isAssignableFrom [class] to-class)]))) + (list& (Class::getGenericSuperclass [] from-class) + (array.to-list (Class::getGenericInterfaces [] from-class))))] (case (|> candiate-parents - (list;filter product;right) - (list/map product;left)) - (#;Cons parent _) + (list.filter product.right) + (list/map product.left)) + (#.Cons parent _) (do @ [mapping (correspond-type-params from-class from) parentT (java-type-to-lux-type mapping parent) [_ castT] (cast direction to parentT)] (wrap [(choose direction to-name from-name) castT])) - #;Nil - (&;throw Cannot-Cast (cannot-cast to from))))))) + #.Nil + (&.throw Cannot-Cast (cannot-cast to from))))))) (def: (infer-out outputT) (-> Type (Meta [Text Type])) - (do macro;Monad<Meta> - [expectedT macro;expected-type + (do macro.Monad<Meta> + [expectedT macro.expected-type [unboxed castT] (cast #Out expectedT outputT) - _ (&;with-type-env - (tc;check expectedT castT))] + _ (&.with-type-env + (tc.check expectedT castT))] (wrap [unboxed castT]))) (def: (find-field class-name field-name) (-> Text Text (Meta [(Class Object) Field])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name)] - (case (Class.getDeclaredField [field-name] class) - (#e;Success field) - (let [owner (Field.getDeclaringClass [] field)] + (case (Class::getDeclaredField [field-name] class) + (#e.Success field) + (let [owner (Field::getDeclaringClass [] field)] (if (is owner class) (wrap [class field]) - (&;throw Mistaken-Field-Owner + (&.throw Mistaken-Field-Owner (format " Field: " field-name "\n" - " Owner Class: " (Class.getName [] owner) "\n" + " Owner Class: " (Class::getName [] owner) "\n" "Target Class: " class-name "\n")))) - (#e;Error _) - (&;throw Unknown-Field (format class-name "#" field-name))))) + (#e.Error _) + (&.throw Unknown-Field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Meta [Type Bool])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (Modifier.isStatic [modifiers]) - (let [fieldJT (Field.getGenericType [] fieldJ)] + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (Modifier::isStatic [modifiers]) + (let [fieldJT (Field::getGenericType [] fieldJ)] (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])]))) - (&;throw Not-Static-Field (format class-name "#" field-name))))) + (wrap [fieldT (Modifier::isFinal [modifiers])]))) + (&.throw Not-Static-Field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Meta [Type Bool])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (not (Modifier.isStatic [modifiers])) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (not (Modifier::isStatic [modifiers])) (do @ - [#let [fieldJT (Field.getGenericType [] fieldJ) + [#let [fieldJT (Field::getGenericType [] fieldJ) var-names (|> class - (Class.getTypeParameters []) - array;to-list - (list/map (TypeVariable.getName [])))] + (Class::getTypeParameters []) + array.to-list + (list/map (TypeVariable::getName [])))] mappings (: (Meta Mappings) (case objectT - (#;Primitive _class-name _class-params) + (#.Primitive _class-name _class-params) (do @ - [#let [num-params (list;size _class-params) - num-vars (list;size var-names)] - _ (&;assert Type-Parameter-Mismatch + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (&.assert Type-Parameter-Mismatch (format "Expected: " (%i (nat-to-int num-params)) "\n" " Actual: " (%i (nat-to-int num-vars)) "\n" " Class: " _class-name "\n" " Type: " (%type objectT)) - (n.= num-params num-vars))] - (wrap (|> (list;zip2 var-names _class-params) - (dict;from-list text;Hash<Text>)))) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dict.from-list text.Hash<Text>)))) _ - (&;throw Non-Object (%type objectT)))) + (&.throw Non-Object (%type objectT)))) fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])])) - (&;throw Not-Virtual-Field (format class-name "#" field-name))))) + (wrap [fieldT (Modifier::isFinal [modifiers])])) + (&.throw Not-Virtual-Field (format class-name "#" field-name))))) (def: (analyse-object class analyse sourceC) - (-> Text &;Analyser Code (Meta [Type la;Analysis])) - (do macro;Monad<Meta> + (-> Text &.Analyser Code (Meta [Type la.Analysis])) + (do macro.Monad<Meta> [target-class (load-class class) targetT (java-type-to-lux-type fresh-mappings - (:! java.lang.reflect.Type + (:! java/lang/reflect/Type target-class)) - [sourceT sourceA] (&common;with-unknown-type + [sourceT sourceA] (&common.with-unknown-type (analyse sourceC)) [unboxed castT] (cast #Out targetT sourceT) - _ (&;assert Cannot-Cast (cannot-cast targetT sourceT) - (not (dict;contains? unboxed boxes)))] + _ (&.assert Cannot-Cast (cannot-cast targetT sourceT) + (not (dict.contains? unboxed boxes)))] (wrap [castT sourceA]))) (def: (analyse-input analyse targetT sourceC) - (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) - (do macro;Monad<Meta> - [[sourceT sourceA] (&common;with-unknown-type + (-> &.Analyser Type Code (Meta [Type Text la.Analysis])) + (do macro.Monad<Meta> + [[sourceT sourceA] (&common.with-unknown-type (analyse sourceC)) [unboxed castT] (cast #In targetT sourceT)] (wrap [castT unboxed sourceA]))) (def: (static-get proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[fieldT final?] (static-field class field) [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed))))) + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: (static-put proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC valueC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> - [_ (&;infer Unit) + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [_ (&.infer Unit) [fieldT final?] (static-field class field) - _ (&;assert Cannot-Set-Final-Field (format class "#" field) + _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;with-type-env - (tc;check fieldT valueT))] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) valueA)))) + _ (&.with-type-env + (tc.check fieldT valueT))] + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed) valueA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: (virtual-get proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC objectC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) objectA)))) + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed) objectA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: (virtual-put proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) - _ (&;infer objectT) + _ (&.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (&;assert Cannot-Set-Final-Field (format class "#" field) + _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC)] - (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) + (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +4 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +4 (list.size args)))))) (def: (java-type-to-parameter type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (macro/wrap (Class.getName [] (:! Class type))) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) - (host;instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) - (or (host;instance? TypeVariable type) - (host;instance? WildcardType type)) + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) (macro/wrap "java.lang.Object") - (host;instance? GenericArrayType type) - (do macro;Monad<Meta> - [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))] + (host.instance? GenericArrayType type) + (do macro.Monad<Meta> + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] (wrap (format componentP "[]"))) ## else - (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) + (&.throw Cannot-Convert-To-Parameter (type-descriptor type)))) (type: Method-Type #Static @@ -917,326 +917,326 @@ (def: (check-method class method-name method-type arg-classes method) (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) - (do macro;Monad<Meta> - [parameters (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ java-type-to-parameter)) - #let [modifiers (Method.getModifiers [] method)]] - (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method)) - (text/= method-name (Method.getName [] method)) + (do macro.Monad<Meta> + [parameters (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers [] method)]] + (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method)) + (text/= method-name (Method::getName [] method)) (case #Static #Special - (Modifier.isStatic [modifiers]) + (Modifier::isStatic [modifiers]) _ true) (case method-type #Special - (not (or (Modifier.isInterface [(Class.getModifiers [] class)]) - (Modifier.isAbstract [modifiers]))) + (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) + (Modifier::isAbstract [modifiers]))) _ true) - (n.= (list;size arg-classes) (list;size parameters)) + (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function [[expectedJC actualJC] prev] (and prev (text/= expectedJC actualJC))) true - (list;zip2 arg-classes parameters)))))) + (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro;Monad<Meta> - [parameters (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ java-type-to-parameter))] - (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor)) - (n.= (list;size arg-classes) (list;size parameters)) + (do macro.Monad<Meta> + [parameters (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor)) + (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function [[expectedJC actualJC] prev] (and prev (text/= expectedJC actualJC))) true - (list;zip2 arg-classes parameters)))))) + (list.zip2 arg-classes parameters)))))) (def: idx-to-bound (-> Nat Type) - (|>. (n.* +2) n.inc #;Bound)) + (|>> (n/* +2) n/inc #.Bound)) (def: (type-vars amount offset) (-> Nat Nat (List Type)) - (if (n.= +0 amount) + (if (n/= +0 amount) (list) - (|> (list;n.range offset (|> amount n.dec (n.+ offset))) + (|> (list.n/range offset (|> amount n/dec (n/+ offset))) (list/map idx-to-bound)))) (def: (method-to-type method-type method) (-> Method-Type Method (Meta [Type (List Type)])) - (let [owner (Method.getDeclaringClass [] method) - owner-name (Class.getName [] owner) + (let [owner (Method::getDeclaringClass [] method) + owner-name (Class::getName [] owner) owner-tvars (case method-type #Static (list) _ - (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName [])))) - method-tvars (|> (Method.getTypeParameters [] method) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) - num-method-tvars (list;size method-tvars) + (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName [])))) + method-tvars (|> (Method::getTypeParameters [] method) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) all-tvars (list/compose owner-tvars method-tvars) - num-all-tvars (list;size all-tvars) + num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars +0) method-tvarsT (type-vars num-method-tvars num-owner-tvars) mappings (: Mappings - (if (list;empty? all-tvars) + (if (list.empty? all-tvars) fresh-mappings (|> (list/compose owner-tvarsT method-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash<Text>))))] - (do macro;Monad<Meta> - [inputsT (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) - exceptionsT (|> (Method.getGenericExceptionTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type;univ-q num-all-tvars) - (type;function (case method-type + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash<Text>))))] + (do macro.Monad<Meta> + [inputsT (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method)) + exceptionsT (|> (Method::getGenericExceptionTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-type #Static inputsT _ - (list& (#;Primitive owner-name (list;reverse owner-tvarsT)) + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) (def: (methods class-name method-name method-type arg-classes) (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name) candidates (|> class - (Class.getDeclaredMethods []) - array;to-list - (monad;map @ (function [method] + (Class::getDeclaredMethods []) + array.to-list + (monad.map @ (function [method] (do @ [passes? (check-method class method-name method-type arg-classes method)] (wrap [passes? method])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidates (format class-name "#" method-name)) + (case (list.filter product.left candidates) + #.Nil + (&.throw No-Candidates (format class-name "#" method-name)) - (#;Cons candidate #;Nil) - (|> candidate product;right (method-to-type method-type)) + (#.Cons candidate #.Nil) + (|> candidate product.right (method-to-type method-type)) _ - (&;throw Too-Many-Candidates (format class-name "#" method-name))))) + (&.throw Too-Many-Candidates (format class-name "#" method-name))))) (def: (constructor-to-type constructor) (-> (Constructor Object) (Meta [Type (List Type)])) - (let [owner (Constructor.getDeclaringClass [] constructor) - owner-name (Class.getName [] owner) - owner-tvars (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName []))) - constructor-tvars (|> (Constructor.getTypeParameters [] constructor) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) + (let [owner (Constructor::getDeclaringClass [] constructor) + owner-name (Class::getName [] owner) + owner-tvars (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName []))) + constructor-tvars (|> (Constructor::getTypeParameters [] constructor) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) all-tvars (list/compose owner-tvars constructor-tvars) - num-all-tvars (list;size all-tvars) + num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars +0) constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) mappings (: Mappings - (if (list;empty? all-tvars) + (if (list.empty? all-tvars) fresh-mappings (|> (list/compose owner-tvarsT constructor-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash<Text>))))] - (do macro;Monad<Meta> - [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT)) - constructorT (<| (type;univ-q num-all-tvars) - (type;function inputsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash<Text>))))] + (do macro.Monad<Meta> + [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) objectT)]] (wrap [constructorT exceptionsT])))) (def: (constructor-methods class-name arg-classes) (-> Text (List Text) (Meta [Type (List Type)])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name) candidates (|> class - (Class.getConstructors []) - array;to-list - (monad;map @ (function [constructor] + (Class::getConstructors []) + array.to-list + (monad.map @ (function [constructor] (do @ [passes? (check-constructor class arg-classes constructor)] (wrap [passes? constructor])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")")) + (case (list.filter product.left candidates) + #.Nil + (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) - (#;Cons candidate #;Nil) - (|> candidate product;right constructor-to-type) + (#.Cons candidate #.Nil) + (|> candidate product.right constructor-to-type) _ - (&;throw Too-Many-Candidates class-name)))) + (&.throw Too-Many-Candidates class-name)))) (def: (decorate-inputs typesT inputsA) - (-> (List Text) (List la;Analysis) (List la;Analysis)) + (-> (List Text) (List la.Analysis) (List la.Analysis)) (|> inputsA - (list;zip2 (list/map code;text typesT)) + (list.zip2 (list/map code.text typesT)) (list/map (function [[type value]] - (la;product (list type value)))))) + (la.product (list type value)))))) (def: (sub-type-analyser analyse) - (-> &;Analyser &;Analyser) + (-> &.Analyser &.Analyser) (function [argC] - (do macro;Monad<Meta> - [[argT argA] (&common;with-unknown-type + (do macro.Monad<Meta> + [[argT argA] (&common.with-unknown-type (analyse argC)) - expectedT macro;expected-type + expectedT macro.expected-type [unboxed castT] (cast #In expectedT argT)] (wrap argA)))) (def: (invoke//static proc) - (-> Text @;Proc) + (-> Text @.Proc) (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]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (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]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//virtual proc) - (-> Text @;Proc) + (-> Text @.Proc) (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]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (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]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) #let [[objectA argsA] (case allA - (#;Cons objectA argsA) + (#.Cons objectA argsA) [objectA argsA] _ (undefined))] [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) objectA (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) objectA (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//special proc) - (-> Text @;Proc) + (-> Text @.Proc) (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 _]]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (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 _]]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//interface proc) - (-> Text @;Proc) + (-> Text @.Proc) (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]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (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]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] class (load-class class-name) - _ (&;assert Non-Interface class-name - (Modifier.isInterface [(Class.getModifiers [] class)])) + _ (&.assert Non-Interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (methods class-name method #Interface argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc - (list& (code;text class-name) (code;text method) (code;text unboxed) + (wrap (la.procedure proc + (list& (code.text class-name) (code.text method) (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//constructor proc) - (-> Text @;Proc) + (-> Text @.Proc) (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]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (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]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: member-procs - @;Bundle - (<| (@;prefix "member") - (|> (dict;new text;Hash<Text>) - (dict;merge (<| (@;prefix "static") - (|> (dict;new text;Hash<Text>) - (@;install "get" static-get) - (@;install "put" static-put)))) - (dict;merge (<| (@;prefix "virtual") - (|> (dict;new text;Hash<Text>) - (@;install "get" virtual-get) - (@;install "put" virtual-put)))) - (dict;merge (<| (@;prefix "invoke") - (|> (dict;new text;Hash<Text>) - (@;install "static" invoke//static) - (@;install "virtual" invoke//virtual) - (@;install "special" invoke//special) - (@;install "interface" invoke//interface) - (@;install "constructor" invoke//constructor) + @.Bundle + (<| (@.prefix "member") + (|> (dict.new text.Hash<Text>) + (dict.merge (<| (@.prefix "static") + (|> (dict.new text.Hash<Text>) + (@.install "get" static-get) + (@.install "put" static-put)))) + (dict.merge (<| (@.prefix "virtual") + (|> (dict.new text.Hash<Text>) + (@.install "get" virtual-get) + (@.install "put" virtual-put)))) + (dict.merge (<| (@.prefix "invoke") + (|> (dict.new text.Hash<Text>) + (@.install "static" invoke//static) + (@.install "virtual" invoke//virtual) + (@.install "special" invoke//special) + (@.install "interface" invoke//interface) + (@.install "constructor" invoke//constructor) ))) ))) (def: #export procedures - @;Bundle - (<| (@;prefix "jvm") - (|> (dict;new text;Hash<Text>) - (dict;merge conversion-procs) - (dict;merge int-procs) - (dict;merge long-procs) - (dict;merge float-procs) - (dict;merge double-procs) - (dict;merge char-procs) - (dict;merge array-procs) - (dict;merge object-procs) - (dict;merge member-procs) + @.Bundle + (<| (@.prefix "jvm") + (|> (dict.new text.Hash<Text>) + (dict.merge conversion-procs) + (dict.merge int-procs) + (dict.merge long-procs) + (dict.merge float-procs) + (dict.merge double-procs) + (dict.merge char-procs) + (dict.merge array-procs) + (dict.merge object-procs) + (dict.merge member-procs) ))) diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux index c660408de..56aba35de 100644 --- a/new-luxc/source/luxc/lang/analysis/reference.lux +++ b/new-luxc/source/luxc/lang/analysis/reference.lux @@ -1,56 +1,56 @@ -(;module: +(.module: lux (lux (control monad) [macro] (macro [code]) (lang (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] + (lang ["&." scope] ["la" analysis #+ Analysis] - [";L" variable #+ Variable]))) + [".L" variable #+ Variable]))) ## [Analysers] (def: (analyse-definition def-name) (-> Ident (Meta Analysis)) - (do macro;Monad<Meta> - [[actualT def-anns _] (&;with-error-tracking - (macro;find-def def-name))] - (case (macro;get-symbol-ann (ident-for #;alias) def-anns) - (#;Some real-def-name) + (do macro.Monad<Meta> + [[actualT def-anns _] (&.with-error-tracking + (macro.find-def def-name))] + (case (macro.get-symbol-ann (ident-for #.alias) def-anns) + (#.Some real-def-name) (analyse-definition real-def-name) _ (do @ - [_ (&;infer actualT) - def-name (macro;normalize def-name)] - (wrap (code;symbol def-name)))))) + [_ (&.infer actualT) + def-name (macro.normalize def-name)] + (wrap (code.symbol def-name)))))) (def: (analyse-variable var-name) (-> Text (Meta (Maybe Analysis))) - (do macro;Monad<Meta> - [?var (&scope;find var-name)] + (do macro.Monad<Meta> + [?var (&scope.find var-name)] (case ?var - (#;Some [actualT ref]) + (#.Some [actualT ref]) (do @ - [_ (&;infer actualT)] - (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref)))))))) + [_ (&.infer actualT)] + (wrap (#.Some (` ((~ (code.int (variableL.from-ref ref)))))))) - #;None - (wrap #;None)))) + #.None + (wrap #.None)))) (def: #export (analyse-reference reference) (-> Ident (Meta Analysis)) (case reference ["" simple-name] - (do macro;Monad<Meta> + (do macro.Monad<Meta> [?var (analyse-variable simple-name)] (case ?var - (#;Some varA) + (#.Some varA) (wrap varA) - #;None + #.None (do @ - [this-module macro;current-module-name] + [this-module macro.current-module-name] (analyse-definition [this-module simple-name])))) _ diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index e6cd2dbad..fb521d02e 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -14,11 +14,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] - ["&;" module] + (lang ["&." scope] + ["&." module] ["la" analysis] - (analysis ["&;" common] - ["&;" inference])))) + (analysis ["&." common] + ["&." inference])))) (exception: #export Invalid-Variant-Type) (exception: #export Invalid-Tuple-Type) @@ -34,46 +34,46 @@ (exception: #export Record-Size-Mismatch) (def: #export (analyse-sum analyse tag valueC) - (-> &;Analyser Nat Code (Meta la;Analysis)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] - (&;with-stacked-errors + (-> &.Analyser Nat Code (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (&.with-stacked-errors (function [_] (Cannot-Analyse-Variant (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC)))) (case expectedT - (#;Sum _) - (let [flat (type;flatten-variant expectedT) - type-size (list;size flat)] - (case (list;nth tag flat) - (#;Some variant-type) + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat)] + (case (list.nth tag flat) + (#.Some variant-type) (do @ - [valueA (&;with-type variant-type + [valueA (&.with-type variant-type (analyse valueC)) - temp &scope;next-local] - (wrap (la;sum tag type-size temp valueA))) + temp &scope.next-local] + (wrap (la.sum tag type-size temp valueA))) - #;None - (&common;variant-out-of-bounds-error expectedT type-size tag))) + #.None + (&common.variant-out-of-bounds-error expectedT type-size tag))) - (#;Named name unnamedT) - (&;with-type unnamedT + (#.Named name unnamedT) + (&.with-type unnamedT (analyse-sum analyse tag valueC)) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') - (&;with-type expectedT' + (#.Some expectedT') + (&.with-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. - (&;throw Cannot-Infer-Numeric-Tag (format " Type: " (%type expectedT) "\n" + (&.throw Cannot-Infer-Numeric-Tag (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))) )) @@ -81,59 +81,59 @@ (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (&;with-type-env <instancer>)] - (&;with-type (maybe;assume (type;apply (list instanceT) expectedT)) + [[instance-id instanceT] (&.with-type-env <instancer>)] + (&.with-type (maybe.assume (type.apply (list instanceT) expectedT)) (analyse-sum analyse tag valueC)))) - ([#;UnivQ tc;existential] - [#;ExQ tc;var]) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Apply inputT funT) + (#.Apply inputT funT) (case funT - (#;Var funT-id) + (#.Var funT-id) (do @ - [?funT' (&;with-type-env (tc;read funT-id))] + [?funT' (&.with-type-env (tc.read funT-id))] (case ?funT' - (#;Some funT') - (&;with-type (#;Apply inputT funT') + (#.Some funT') + (&.with-type (#.Apply inputT funT') (analyse-sum analyse tag valueC)) _ - (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))))) _ - (case (type;apply (list inputT) funT) - #;None - (&;throw Not-Quantified-Type (%type funT)) + (case (type.apply (list inputT) funT) + #.None + (&.throw Not-Quantified-Type (%type funT)) - (#;Some outputT) - (&;with-type outputT + (#.Some outputT) + (&.with-type outputT (analyse-sum analyse tag valueC)))) _ - (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))))))) (def: (analyse-typed-product analyse membersC+) - (-> &;Analyser (List Code) (Meta la;Analysis)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] + (-> &.Analyser (List Code) (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] (loop [expectedT expectedT membersC+ membersC+] (case [expectedT membersC+] ## If the tuple runs out, whatever expression is the last gets ## matched to the remaining type. - [tailT (#;Cons tailC #;Nil)] - (&;with-type tailT + [tailT (#.Cons tailC #.Nil)] + (&.with-type tailT (analyse tailC)) ## If the type and the code are still ongoing, match each ## sub-expression to its corresponding type. - [(#;Product leftT rightT) (#;Cons leftC rightC)] + [(#.Product leftT rightT) (#.Cons leftC rightC)] (do @ - [leftA (&;with-type leftT + [leftA (&.with-type leftT (analyse leftC)) rightA (recur rightT rightC)] (wrap (` [(~ leftA) (~ rightA)]))) @@ -157,98 +157,98 @@ ## and what was analysed. [tailT tailC] (do @ - [g!tail (macro;gensym "tail")] - (&;with-type tailT + [g!tail (macro.gensym "tail")] + (&.with-type tailT (analyse (` ("lux case" [(~@ tailC)] (~ g!tail) (~ g!tail)))))) )))) (def: #export (analyse-product analyse membersC) - (-> &;Analyser (List Code) (Meta la;Analysis)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] - (&;with-stacked-errors + (-> &.Analyser (List Code) (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (&.with-stacked-errors (function [_] (Cannot-Analyse-Tuple (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)]))))) (case expectedT - (#;Product _) + (#.Product _) (analyse-typed-product analyse membersC) - (#;Named name unnamedT) - (&;with-type unnamedT + (#.Named name unnamedT) + (&.with-type unnamedT (analyse-product analyse membersC)) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') - (&;with-type expectedT' + (#.Some expectedT') + (&.with-type expectedT' (analyse-product analyse membersC)) _ ## Must do inference... (do @ - [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + [membersTA (monad.map @ (|>> analyse &common.with-unknown-type) membersC) - _ (&;with-type-env - (tc;check expectedT - (type;tuple (list/map product;left membersTA))))] - (wrap (la;product (list/map product;right membersTA)))))) + _ (&.with-type-env + (tc.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (la.product (list/map product.right membersTA)))))) (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (&;with-type-env <instancer>)] - (&;with-type (maybe;assume (type;apply (list instanceT) expectedT)) + [[instance-id instanceT] (&.with-type-env <instancer>)] + (&.with-type (maybe.assume (type.apply (list instanceT) expectedT)) (analyse-product analyse membersC)))) - ([#;UnivQ tc;existential] - [#;ExQ tc;var]) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Apply inputT funT) + (#.Apply inputT funT) (case funT - (#;Var funT-id) + (#.Var funT-id) (do @ - [?funT' (&;with-type-env (tc;read funT-id))] + [?funT' (&.with-type-env (tc.read funT-id))] (case ?funT' - (#;Some funT') - (&;with-type (#;Apply inputT funT') + (#.Some funT') + (&.with-type (#.Apply inputT funT') (analyse-product analyse membersC)) _ - (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)])))))) _ - (case (type;apply (list inputT) funT) - #;None - (&;throw Not-Quantified-Type (%type funT)) + (case (type.apply (list inputT) funT) + #.None + (&.throw Not-Quantified-Type (%type funT)) - (#;Some outputT) - (&;with-type outputT + (#.Some outputT) + (&.with-type outputT (analyse-product analyse membersC)))) _ - (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)])))) )))) (def: #export (analyse-tagged-sum analyse tag valueC) - (-> &;Analyser Ident Code (Meta la;Analysis)) - (do macro;Monad<Meta> - [tag (macro;normalize tag) - [idx group variantT] (macro;resolve-tag tag) - expectedT macro;expected-type] + (-> &.Analyser Ident Code (Meta la.Analysis)) + (do macro.Monad<Meta> + [tag (macro.normalize tag) + [idx group variantT] (macro.resolve-tag tag) + expectedT macro.expected-type] (case expectedT - (#;Var _) + (#.Var _) (do @ - [#let [case-size (list;size group)] - inferenceT (&inference;variant idx case-size variantT) - [inferredT valueA+] (&inference;general analyse inferenceT (list valueC)) - temp &scope;next-local] - (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) + [#let [case-size (list.size group)] + inferenceT (&inference.variant idx case-size variantT) + [inferredT valueA+] (&inference.general analyse inferenceT (list valueC)) + temp &scope.next-local] + (wrap (la.sum idx case-size temp (|> valueA+ list.head maybe.assume)))) _ (analyse-sum analyse idx valueC)))) @@ -259,17 +259,17 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Meta (List [Ident Code]))) - (monad;map macro;Monad<Meta> + (monad.map macro.Monad<Meta> (function [[key val]] (case key - [_ (#;Tag key)] - (do macro;Monad<Meta> - [key (macro;normalize key)] + [_ (#.Tag key)] + (do macro.Monad<Meta> + [key (macro.normalize key)] (wrap [key val])) _ - (&;throw Record-Keys-Must-Be-Tags (format " Key: " (%code key) "\n" - "Record: " (%code (code;record record)))))) + (&.throw Record-Keys-Must-Be-Tags (format " Key: " (%code key) "\n" + "Record: " (%code (code.record record)))))) record)) ## Lux already possesses the means to analyse tuples, so @@ -279,56 +279,56 @@ (-> (List [Ident Code]) (Meta [(List Code) Type])) (case record ## empty-record = empty-tuple = unit = [] - #;Nil - (:: macro;Monad<Meta> wrap [(list) Unit]) - - (#;Cons [head-k head-v] _) - (do macro;Monad<Meta> - [head-k (macro;normalize head-k) - [_ tag-set recordT] (macro;resolve-tag head-k) - #let [size-record (list;size record) - size-ts (list;size tag-set)] - _ (if (n.= size-ts size-record) + #.Nil + (:: macro.Monad<Meta> wrap [(list) Unit]) + + (#.Cons [head-k head-v] _) + (do macro.Monad<Meta> + [head-k (macro.normalize head-k) + [_ tag-set recordT] (macro.resolve-tag head-k) + #let [size-record (list.size record) + size-ts (list.size tag-set)] + _ (if (n/= size-ts size-record) (wrap []) - (&;throw Record-Size-Mismatch + (&.throw Record-Size-Mismatch (format " Expected: " (|> size-ts nat-to-int %i) "\n" " Actual: " (|> size-record nat-to-int %i) "\n" " Type: " (%type recordT) "\n" "Expression: " (%code (|> record (list/map (function [[keyI valueC]] - [(code;tag keyI) valueC])) - code;record))))) - #let [tuple-range (list;n.range +0 (n.dec size-ts)) - tag->idx (dict;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] - idx->val (monad;fold @ + [(code.tag keyI) valueC])) + code.record))))) + #let [tuple-range (list.n/range +0 (n/dec size-ts)) + tag->idx (dict.from-list ident.Hash<Ident> (list.zip2 tag-set tuple-range))] + idx->val (monad.fold @ (function [[key val] idx->val] (do @ - [key (macro;normalize key)] - (case (dict;get key tag->idx) - #;None - (&;throw Tag-Does-Not-Belong-To-Record - (format " Tag: " (%code (code;tag key)) "\n" + [key (macro.normalize key)] + (case (dict.get key tag->idx) + #.None + (&.throw Tag-Does-Not-Belong-To-Record + (format " Tag: " (%code (code.tag key)) "\n" "Type: " (%type recordT))) - (#;Some idx) - (if (dict;contains? idx idx->val) - (&;throw Cannot-Repeat-Tag - (format " Tag: " (%code (code;tag key)) "\n" - "Record: " (%code (code;record (list/map (function [[keyI valC]] - [(code;tag keyI) valC]) + (#.Some idx) + (if (dict.contains? idx idx->val) + (&.throw Cannot-Repeat-Tag + (format " Tag: " (%code (code.tag key)) "\n" + "Record: " (%code (code.record (list/map (function [[keyI valC]] + [(code.tag keyI) valC]) record))))) - (wrap (dict;put idx val idx->val)))))) + (wrap (dict.put idx val idx->val)))))) (: (Dict Nat Code) - (dict;new number;Hash<Nat>)) + (dict.new number.Hash<Nat>)) record) - #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val))) + #let [ordered-tuple (list/map (function [idx] (maybe.assume (dict.get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) )) (def: #export (analyse-record analyse members) - (-> &;Analyser (List [Code Code]) (Meta la;Analysis)) - (do macro;Monad<Meta> + (-> &.Analyser (List [Code Code]) (Meta la.Analysis)) + (do macro.Monad<Meta> [members (normalize members) [membersC recordT] (order members)] (case membersC @@ -337,13 +337,13 @@ _ (do @ - [expectedT macro;expected-type] + [expectedT macro.expected-type] (case expectedT - (#;Var _) + (#.Var _) (do @ - [inferenceT (&inference;record recordT) - [inferredT membersA] (&inference;general analyse inferenceT membersC)] - (wrap (la;product membersA))) + [inferenceT (&inference.record recordT) + [inferredT membersA] (&inference.general analyse inferenceT membersC)] + (wrap (la.product membersA))) _ (analyse-product analyse membersC)))))) diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux index f85608e19..c3296fd21 100644 --- a/new-luxc/source/luxc/lang/analysis/type.lux +++ b/new-luxc/source/luxc/lang/analysis/type.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) [macro] @@ -10,18 +10,18 @@ ## means of evaluating Lux expressions at compile-time for the sake of ## computing Lux type values. (def: #export (analyse-check analyse eval type value) - (-> &;Analyser &;Eval Code Code (Meta Analysis)) - (do macro;Monad<Meta> + (-> &.Analyser &.Eval Code Code (Meta Analysis)) + (do macro.Monad<Meta> [actualT (eval Type type) #let [actualT (:! Type actualT)] - _ (&;infer actualT)] - (&;with-type actualT + _ (&.infer actualT)] + (&.with-type actualT (analyse value)))) (def: #export (analyse-coerce analyse eval type value) - (-> &;Analyser &;Eval Code Code (Meta Analysis)) - (do macro;Monad<Meta> + (-> &.Analyser &.Eval Code Code (Meta Analysis)) + (do macro.Monad<Meta> [actualT (eval Type type) - _ (&;infer (:! Type actualT))] - (&;with-type Top + _ (&.infer (:! Type actualT))] + (&.with-type Top (analyse value)))) diff --git a/new-luxc/source/luxc/lang/eval.lux b/new-luxc/source/luxc/lang/eval.lux index e691ec7a1..62d6a438b 100644 --- a/new-luxc/source/luxc/lang/eval.lux +++ b/new-luxc/source/luxc/lang/eval.lux @@ -1,18 +1,18 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) [macro]) (luxc ["&" lang] - (lang (analysis [";A" expression]) - (synthesis [";S" expression]) - (translation [";T" expression] - [";T" eval])))) + (lang (analysis [".A" expression]) + (synthesis [".S" expression]) + (translation [".T" expression] + [".T" eval])))) (def: #export (eval type exprC) - &;Eval - (do macro;Monad<Meta> - [exprA (&;with-type type - (expressionA;analyser eval exprC)) - #let [exprS (expressionS;synthesize exprA)] - exprI (expressionT;translate exprS)] - (evalT;eval exprI))) + &.Eval + (do macro.Monad<Meta> + [exprA (&.with-type type + (expressionA.analyser eval exprC)) + #let [exprS (expressionS.synthesize exprA)] + exprI (expressionT.translate exprS)] + (evalT.eval exprI))) diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux index 9f8fcd069..c980eab9d 100644 --- a/new-luxc/source/luxc/lang/host.jvm.lux +++ b/new-luxc/source/luxc/lang/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -13,172 +13,172 @@ [host #+ do-to object] [io]) (luxc ["&" lang] - (lang [";L" variable #+ Register] - (translation [";T" common])))) + (lang [".L" variable #+ Register] + (translation [".T" common])))) -(host;import org.objectweb.asm.Label) +(host.import org/objectweb/asm/Label) -(host;import java.lang.reflect.AccessibleObject +(host.import java/lang/reflect/AccessibleObject (setAccessible [boolean] void)) -(host;import java.lang.reflect.Method +(host.import java/lang/reflect/Method (invoke [Object (Array Object)] #try Object)) -(host;import (java.lang.Class a) +(host.import (java/lang/Class a) (getDeclaredMethod [String (Array (Class Object))] #try Method)) -(host;import java.lang.Object +(host.import java/lang/Object (getClass [] (Class Object))) -(host;import java.lang.Integer +(host.import java/lang/Integer (#static TYPE (Class Integer))) -(host;import java.lang.ClassLoader) +(host.import java/lang/ClassLoader) (def: ClassLoader::defineClass Method - (case (Class.getDeclaredMethod ["defineClass" - (|> (host;array (Class Object) +4) - (host;array-write +0 (:! (Class Object) (host;class-for String))) - (host;array-write +1 (Object.getClass [] (host;array byte +0))) - (host;array-write +2 (:! (Class Object) Integer.TYPE)) - (host;array-write +3 (:! (Class Object) Integer.TYPE)))] - (host;class-for java.lang.ClassLoader)) - (#e;Success method) + (case (Class::getDeclaredMethod ["defineClass" + (|> (host.array (Class Object) +4) + (host.array-write +0 (:! (Class Object) (host.class-for String))) + (host.array-write +1 (Object::getClass [] (host.array byte +0))) + (host.array-write +2 (:! (Class Object) Integer::TYPE)) + (host.array-write +3 (:! (Class Object) Integer::TYPE)))] + (host.class-for java/lang/ClassLoader)) + (#e.Success method) (do-to method - (AccessibleObject.setAccessible [true])) + (AccessibleObject::setAccessible [true])) - (#e;Error error) + (#e.Error error) (error! error))) (def: (define-class class-name byte-code loader) - (-> Text commonT;Bytecode ClassLoader (e;Error Object)) - (Method.invoke [loader - (array;from-list (list (:! Object class-name) - (:! Object byte-code) - (:! Object (host;l2i 0)) - (:! Object (host;l2i (nat-to-int (host;array-length byte-code))))))] - ClassLoader::defineClass)) + (-> Text commonT.Bytecode ClassLoader (e.Error Object)) + (Method::invoke [loader + (array.from-list (list (:! Object class-name) + (:! Object byte-code) + (:! Object (host.l2i 0)) + (:! Object (host.l2i (nat-to-int (host.array-length byte-code))))))] + ClassLoader::defineClass)) (def: (fetch-byte-code class-name store) - (-> Text commonT;Class-Store (Maybe commonT;Bytecode)) - (|> store atom;read io;run (dict;get class-name))) + (-> Text commonT.Class-Store (Maybe commonT.Bytecode)) + (|> store atom.read io.run (dict.get class-name))) (def: (memory-class-loader store) - (-> commonT;Class-Store ClassLoader) + (-> commonT.Class-Store ClassLoader) (object [] ClassLoader [] [] (ClassLoader (findClass [class-name String]) Class (case (fetch-byte-code class-name store) - (#;Some bytecode) + (#.Some bytecode) (case (define-class class-name bytecode (:! ClassLoader _jvm_this)) - (#e;Success class) + (#e.Success class) (:!! class) - (#e;Error error) + (#e.Error error) (error! (format "Class definition error: " class-name "\n" error))) - #;None + #.None (error! (format "Class not found: " class-name)))))) (def: #export init-host - (io;IO commonT;Host) - (io;io (let [store (: commonT;Class-Store - (atom (dict;new text;Hash<Text>)))] - {#commonT;loader (memory-class-loader store) - #commonT;store store - #commonT;artifacts (dict;new text;Hash<Text>) - #commonT;context ["" +0] - #commonT;anchor #;None}))) + (io.IO commonT.Host) + (io.io (let [store (: commonT.Class-Store + (atom (dict.new text.Hash<Text>)))] + {#commonT.loader (memory-class-loader store) + #commonT.store store + #commonT.artifacts (dict.new text.Hash<Text>) + #commonT.context ["" +0] + #commonT.anchor #.None}))) (def: #export (with-anchor anchor expr) (All [a] (-> [Label Register] (Meta a) (Meta a))) - (;function [compiler] - (let [old (:! commonT;Host (get@ #;host compiler))] - (case (expr (set@ #;host - (:! Void (set@ #commonT;anchor (#;Some anchor) old)) + (.function [compiler] + (let [old (:! commonT.Host (get@ #.host compiler))] + (case (expr (set@ #.host + (:! Void (set@ #commonT.anchor (#.Some anchor) old)) compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! commonT;Host) - (set@ #commonT;anchor (get@ #commonT;anchor old)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! commonT.Host) + (set@ #commonT.anchor (get@ #commonT.anchor old)) (:! Void)) compiler') output]) - (#e;Error error) - (#e;Error error))))) + (#e.Error error) + (#e.Error error))))) (exception: #export No-Anchor) (def: #export anchor (Meta [Label Register]) - (;function [compiler] - (case (|> compiler (get@ #;host) (:! commonT;Host) (get@ #commonT;anchor)) - (#;Some anchor) - (#e;Success [compiler + (.function [compiler] + (case (|> compiler (get@ #.host) (:! commonT.Host) (get@ #commonT.anchor)) + (#.Some anchor) + (#e.Success [compiler anchor]) - #;None - ((&;throw No-Anchor "") compiler)))) + #.None + ((&.throw No-Anchor "") compiler)))) (def: #export (with-context name expr) (All [a] (-> Text (Meta a) (Meta a))) - (;function [compiler] - (let [old (:! commonT;Host (get@ #;host compiler))] - (case (expr (set@ #;host - (:! Void (set@ #commonT;context [(&;normalize-name name) +0] old)) + (.function [compiler] + (let [old (:! commonT.Host (get@ #.host compiler))] + (case (expr (set@ #.host + (:! Void (set@ #commonT.context [(&.normalize-name name) +0] old)) compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! commonT;Host) - (set@ #commonT;context (get@ #commonT;context old)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! commonT.Host) + (set@ #commonT.context (get@ #commonT.context old)) (:! Void)) compiler') output]) - (#e;Error error) - (#e;Error error))))) + (#e.Error error) + (#e.Error error))))) (def: #export (with-sub-context expr) (All [a] (-> (Meta a) (Meta [Text a]))) - (;function [compiler] - (let [old (:! commonT;Host (get@ #;host compiler)) - [old-name old-sub] (get@ #commonT;context old) + (.function [compiler] + (let [old (:! commonT.Host (get@ #.host compiler)) + [old-name old-sub] (get@ #commonT.context old) new-name (format old-name "$" (%i (nat-to-int old-sub)))] - (case (expr (set@ #;host - (:! Void (set@ #commonT;context [new-name +0] old)) + (case (expr (set@ #.host + (:! Void (set@ #commonT.context [new-name +0] old)) compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! commonT;Host) - (set@ #commonT;context [old-name (n.inc old-sub)]) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! commonT.Host) + (set@ #commonT.context [old-name (n/inc old-sub)]) (:! Void)) compiler') [new-name output]]) - (#e;Error error) - (#e;Error error))))) + (#e.Error error) + (#e.Error error))))) (def: #export context (Meta Text) - (;function [compiler] - (#e;Success [compiler - (|> (get@ #;host compiler) - (:! commonT;Host) - (get@ #commonT;context) + (.function [compiler] + (#e.Success [compiler + (|> (get@ #.host compiler) + (:! commonT.Host) + (get@ #commonT.context) (let> [name sub] name))]))) (def: #export class-loader (Meta ClassLoader) (function [compiler] - (#e;Success [compiler + (#e.Success [compiler (|> compiler - (get@ #;host) - (:! commonT;Host) - (get@ #commonT;loader))]))) + (get@ #.host) + (:! commonT.Host) + (get@ #commonT.loader))]))) (def: #export runtime-class Text "LuxRuntime") (def: #export function-class Text "LuxFunction") diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index f96b3e646..cfe71656c 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- Type Def] (lux (control monad ["p" parser]) @@ -9,11 +9,11 @@ [host])) ## [Host] -(host;import org.objectweb.asm.MethodVisitor) +(host.import org/objectweb/asm/MethodVisitor) -(host;import org.objectweb.asm.ClassWriter) +(host.import org/objectweb/asm/ClassWriter) -(host;import #long org.objectweb.asm.Label +(host.import #long org/objectweb/asm/Label (new [])) ## [Type] @@ -59,7 +59,7 @@ (-> MethodVisitor MethodVisitor)) (type: #export Label - org.objectweb.asm.Label) + org/objectweb/asm/Label) (type: #export Register Nat) @@ -70,45 +70,45 @@ #Default) (type: #export Version - #V1.1 - #V1.2 - #V1.3 - #V1.4 - #V1.5 - #V1.6 - #V1.7 - #V1.8) + #V1_1 + #V1_2 + #V1_3 + #V1_4 + #V1_5 + #V1_6 + #V1_7 + #V1_8) ## [Values] -(syntax: (config: [type s;local-symbol] - [none s;local-symbol] - [++ s;local-symbol] - [options (s;tuple (p;many s;local-symbol))]) - (let [g!type (code;local-symbol type) - g!none (code;local-symbol none) - g!tags+ (list/map code;local-tag options) - g!_left (code;local-symbol "_left") - g!_right (code;local-symbol "_right") +(syntax: (config: [type s.local-symbol] + [none s.local-symbol] + [++ s.local-symbol] + [options (s.tuple (p.many s.local-symbol))]) + (let [g!type (code.local-symbol type) + g!none (code.local-symbol none) + g!tags+ (list/map code.local-tag options) + g!_left (code.local-symbol "_left") + g!_right (code.local-symbol "_right") g!options+ (list/map (function [option] - (` (def: (~' #export) (~ (code;local-symbol option)) + (` (def: (~' #export) (~ (code.local-symbol option)) (~ g!type) (|> (~ g!none) - (set@ (~ (code;local-tag option)) true))))) + (set@ (~ (code.local-tag option)) true))))) options)] (wrap (list& (` (type: (~' #export) (~ g!type) - (~ (code;record (list/map (function [tag] - [tag (` ;Bool)]) + (~ (code.record (list/map (function [tag] + [tag (` .Bool)]) g!tags+))))) (` (def: (~' #export) (~ g!none) (~ g!type) - (~ (code;record (list/map (function [tag] + (~ (code.record (list/map (function [tag] [tag (` false)]) g!tags+))))) - (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right)) + (` (def: (~' #export) ((~ (code.local-symbol ++)) (~ g!_left) (~ g!_right)) (-> (~ g!type) (~ g!type) (~ g!type)) - (~ (code;record (list/map (function [tag] + (~ (code.record (list/map (function [tag] [tag (` (or (get@ (~ tag) (~ g!_left)) (get@ (~ tag) (~ g!_right))))]) g!tags+))))) @@ -123,7 +123,7 @@ ## Labels (def: #export new-label (-> Unit Label) - org.objectweb.asm.Label.new) + org/objectweb/asm/Label::new) (def: #export (simple-class name) (-> Text Class) diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux index ec1de6b43..8e90172d5 100644 --- a/new-luxc/source/luxc/lang/host/jvm/def.lux +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -1,19 +1,20 @@ -(;module: +(.module: lux (lux (data [text] text/format [product] (coll ["a" array] [list "list/" Functor<List>])) - [host #+ do-to]) + [host #+ do-to] + [function]) ["$" //] (// ["$t" type])) ## [Host] -(host;import #long java.lang.Object) -(host;import #long java.lang.String) +(host.import #long java/lang/Object) +(host.import #long java/lang/String) -(host;import org.objectweb.asm.Opcodes +(host.import org/objectweb/asm/Opcodes (#static ACC_PUBLIC int) (#static ACC_PROTECTED int) (#static ACC_PRIVATE int) @@ -40,15 +41,15 @@ (#static V1_8 int) ) -(host;import org.objectweb.asm.FieldVisitor +(host.import org/objectweb/asm/FieldVisitor (visitEnd [] void)) -(host;import org.objectweb.asm.MethodVisitor +(host.import org/objectweb/asm/MethodVisitor (visitCode [] void) (visitMaxs [int int] void) (visitEnd [] void)) -(host;import org.objectweb.asm.ClassWriter +(host.import org/objectweb/asm/ClassWriter (#static COMPUTE_MAXS int) (#static COMPUTE_FRAMES int) (new [int]) @@ -61,228 +62,228 @@ ## [Defs] (def: (string-array values) (-> (List Text) (Array Text)) - (let [output (host;array String (list;size values))] + (let [output (host.array String (list.size values))] (exec (list/map (function [[idx value]] - (host;array-write idx value output)) - (list;enumerate values)) + (host.array-write idx value output)) + (list.enumerate values)) output))) (def: exceptions-array - (-> $;Method (Array Text)) - (|>. (get@ #$;exceptions) - (list/map (|>. #$;Generic $t;descriptor)) + (-> $.Method (Array Text)) + (|>> (get@ #$.exceptions) + (list/map (|>> #$.Generic $t.descriptor)) string-array)) (def: (version-flag version) - (-> $;Version Int) + (-> $.Version Int) (case version - #$;V1.1 Opcodes.V1_1 - #$;V1.2 Opcodes.V1_2 - #$;V1.3 Opcodes.V1_3 - #$;V1.4 Opcodes.V1_4 - #$;V1.5 Opcodes.V1_5 - #$;V1.6 Opcodes.V1_6 - #$;V1.7 Opcodes.V1_7 - #$;V1.8 Opcodes.V1_8)) + #$.V1_1 Opcodes::V1_1 + #$.V1_2 Opcodes::V1_2 + #$.V1_3 Opcodes::V1_3 + #$.V1_4 Opcodes::V1_4 + #$.V1_5 Opcodes::V1_5 + #$.V1_6 Opcodes::V1_6 + #$.V1_7 Opcodes::V1_7 + #$.V1_8 Opcodes::V1_8)) (def: (visibility-flag visibility) - (-> $;Visibility Int) + (-> $.Visibility Int) (case visibility - #$;Public Opcodes.ACC_PUBLIC - #$;Protected Opcodes.ACC_PROTECTED - #$;Private Opcodes.ACC_PRIVATE - #$;Default 0)) + #$.Public Opcodes::ACC_PUBLIC + #$.Protected Opcodes::ACC_PROTECTED + #$.Private Opcodes::ACC_PRIVATE + #$.Default 0)) (def: (class-flags config) - (-> $;Class-Config Int) - ($_ i.+ - (if (get@ #$;finalC config) Opcodes.ACC_FINAL 0))) + (-> $.Class-Config Int) + ($_ i/+ + (if (get@ #$.finalC config) Opcodes::ACC_FINAL 0))) (def: (method-flags config) - (-> $;Method-Config Int) - ($_ i.+ - (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0) - (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0) - (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0) - (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0))) + (-> $.Method-Config Int) + ($_ i/+ + (if (get@ #$.staticM config) Opcodes::ACC_STATIC 0) + (if (get@ #$.finalM config) Opcodes::ACC_FINAL 0) + (if (get@ #$.synchronizedM config) Opcodes::ACC_SYNCHRONIZED 0) + (if (get@ #$.strictM config) Opcodes::ACC_STRICT 0))) (def: (field-flags config) - (-> $;Field-Config Int) - ($_ i.+ - (if (get@ #$;staticF config) Opcodes.ACC_STATIC 0) - (if (get@ #$;finalF config) Opcodes.ACC_FINAL 0) - (if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0) - (if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0))) + (-> $.Field-Config Int) + ($_ i/+ + (if (get@ #$.staticF config) Opcodes::ACC_STATIC 0) + (if (get@ #$.finalF config) Opcodes::ACC_FINAL 0) + (if (get@ #$.transientF config) Opcodes::ACC_TRANSIENT 0) + (if (get@ #$.volatileF config) Opcodes::ACC_VOLATILE 0))) (def: class-to-type - (-> $;Class $;Type) - (|>. #$;Class #$;Generic)) + (-> $.Class $.Type) + (|>> #$.Class #$.Generic)) (def: param-signature - (-> $;Class Text) - (|>. class-to-type $t;signature (format ":"))) + (-> $.Class Text) + (|>> class-to-type $t.signature (format ":"))) (def: (formal-param [name super interfaces]) - (-> $;Parameter Text) + (-> $.Parameter Text) (format name (param-signature super) (|> interfaces (list/map param-signature) - (text;join-with "")))) + (text.join-with "")))) (def: (parameters-signature parameters super interfaces) - (-> (List $;Parameter) $;Class (List $;Class) + (-> (List $.Parameter) $.Class (List $.Class) Text) - (let [formal-params (if (list;empty? parameters) + (let [formal-params (if (list.empty? parameters) "" (format "<" (|> parameters (list/map formal-param) - (text;join-with "")) + (text.join-with "")) ">"))] (format formal-params - (|> super class-to-type $t;signature) + (|> super class-to-type $t.signature) (|> interfaces - (list/map (|>. class-to-type $t;signature)) - (text;join-with ""))))) + (list/map (|>> class-to-type $t.signature)) + (text.join-with ""))))) (def: class-computes Int - ($_ i.+ - ClassWriter.COMPUTE_MAXS - ## ClassWriter.COMPUTE_FRAMES + ($_ i/+ + ClassWriter::COMPUTE_MAXS + ## ClassWriter::COMPUTE_FRAMES )) (do-template [<name> <flag>] [(def: #export (<name> version visibility config name parameters super interfaces definitions) - (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def - (host;type (Array byte))) - (let [writer (|> (do-to (ClassWriter.new class-computes) - (ClassWriter.visit [(version-flag version) - ($_ i.+ - Opcodes.ACC_SUPER - <flag> - (visibility-flag visibility) - (class-flags config)) - ($t;binary-name name) - (parameters-signature parameters super interfaces) - (|> super product;left $t;binary-name) - (|> interfaces - (list/map (|>. product;left $t;binary-name)) - string-array)])) + (-> $.Version $.Visibility $.Class-Config Text (List $.Parameter) $.Class (List $.Class) $.Def + (host.type (Array byte))) + (let [writer (|> (do-to (ClassWriter::new class-computes) + (ClassWriter::visit [(version-flag version) + ($_ i/+ + Opcodes::ACC_SUPER + <flag> + (visibility-flag visibility) + (class-flags config)) + ($t.binary-name name) + (parameters-signature parameters super interfaces) + (|> super product.left $t.binary-name) + (|> interfaces + (list/map (|>> product.left $t.binary-name)) + string-array)])) definitions) - _ (ClassWriter.visitEnd [] writer)] - (ClassWriter.toByteArray [] writer)))] + _ (ClassWriter::visitEnd [] writer)] + (ClassWriter::toByteArray [] writer)))] [class 0] - [abstract Opcodes.ACC_ABSTRACT] + [abstract Opcodes::ACC_ABSTRACT] ) -(def: $Object $;Class ["java.lang.Object" (list)]) +(def: $Object $.Class ["java.lang.Object" (list)]) (def: #export (interface version visibility config name parameters interfaces definitions) - (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def - (host;type (Array byte))) - (let [writer (|> (do-to (ClassWriter.new class-computes) - (ClassWriter.visit [(version-flag version) - ($_ i.+ - Opcodes.ACC_SUPER - Opcodes.ACC_INTERFACE - (visibility-flag visibility) - (class-flags config)) - ($t;binary-name name) - (parameters-signature parameters $Object interfaces) - (|> $Object product;left $t;binary-name) - (|> interfaces - (list/map (|>. product;left $t;binary-name)) - string-array)])) + (-> $.Version $.Visibility $.Class-Config Text (List $.Parameter) (List $.Class) $.Def + (host.type (Array byte))) + (let [writer (|> (do-to (ClassWriter::new class-computes) + (ClassWriter::visit [(version-flag version) + ($_ i/+ + Opcodes::ACC_SUPER + Opcodes::ACC_INTERFACE + (visibility-flag visibility) + (class-flags config)) + ($t.binary-name name) + (parameters-signature parameters $Object interfaces) + (|> $Object product.left $t.binary-name) + (|> interfaces + (list/map (|>> product.left $t.binary-name)) + string-array)])) definitions) - _ (ClassWriter.visitEnd [] writer)] - (ClassWriter.toByteArray [] writer))) + _ (ClassWriter::visitEnd [] writer)] + (ClassWriter::toByteArray [] writer))) (def: #export (method visibility config name type then) - (-> $;Visibility $;Method-Config Text $;Method $;Inst - $;Def) + (-> $.Visibility $.Method-Config Text $.Method $.Inst + $.Def) (function [writer] - (let [=method (ClassWriter.visitMethod [($_ i.+ - (visibility-flag visibility) - (method-flags config)) - ($t;binary-name name) - ($t;method-descriptor type) - ($t;method-signature type) - (exceptions-array type)] - writer) - _ (MethodVisitor.visitCode [] =method) + (let [=method (ClassWriter::visitMethod [($_ i/+ + (visibility-flag visibility) + (method-flags config)) + ($t.binary-name name) + ($t.method-descriptor type) + ($t.method-signature type) + (exceptions-array type)] + writer) + _ (MethodVisitor::visitCode [] =method) _ (then =method) - _ (MethodVisitor.visitMaxs [0 0] =method) - _ (MethodVisitor.visitEnd [] =method)] + _ (MethodVisitor::visitMaxs [0 0] =method) + _ (MethodVisitor::visitEnd [] =method)] writer))) (def: #export (abstract-method visibility config name type) - (-> $;Visibility $;Method-Config Text $;Method - $;Def) + (-> $.Visibility $.Method-Config Text $.Method + $.Def) (function [writer] - (let [=method (ClassWriter.visitMethod [($_ i.+ - (visibility-flag visibility) - (method-flags config) - Opcodes.ACC_ABSTRACT) - ($t;binary-name name) - ($t;method-descriptor type) - ($t;method-signature type) - (exceptions-array type)] - writer) - _ (MethodVisitor.visitEnd [] =method)] + (let [=method (ClassWriter::visitMethod [($_ i/+ + (visibility-flag visibility) + (method-flags config) + Opcodes::ACC_ABSTRACT) + ($t.binary-name name) + ($t.method-descriptor type) + ($t.method-signature type) + (exceptions-array type)] + writer) + _ (MethodVisitor::visitEnd [] =method)] writer))) (def: #export (field visibility config name type) - (-> $;Visibility $;Field-Config Text $;Type $;Def) + (-> $.Visibility $.Field-Config Text $.Type $.Def) (function [writer] - (let [=field (do-to (ClassWriter.visitField [($_ i.+ - (visibility-flag visibility) - (field-flags config)) - ($t;binary-name name) - ($t;descriptor type) - ($t;signature type) - (host;null)] writer) - (FieldVisitor.visitEnd []))] + (let [=field (do-to (ClassWriter::visitField [($_ i/+ + (visibility-flag visibility) + (field-flags config)) + ($t.binary-name name) + ($t.descriptor type) + ($t.signature type) + (host.null)] writer) + (FieldVisitor::visitEnd []))] writer))) (do-template [<name> <lux-type> <jvm-type> <prepare>] [(def: #export (<name> visibility config name value) - (-> $;Visibility $;Field-Config Text <lux-type> $;Def) + (-> $.Visibility $.Field-Config Text <lux-type> $.Def) (function [writer] - (let [=field (do-to (ClassWriter.visitField [($_ i.+ - (visibility-flag visibility) - (field-flags config)) - ($t;binary-name name) - ($t;descriptor <jvm-type>) - ($t;signature <jvm-type>) - (<prepare> value)] - writer) - (FieldVisitor.visitEnd []))] + (let [=field (do-to (ClassWriter::visitField [($_ i/+ + (visibility-flag visibility) + (field-flags config)) + ($t.binary-name name) + ($t.descriptor <jvm-type>) + ($t.signature <jvm-type>) + (<prepare> value)] + writer) + (FieldVisitor::visitEnd []))] writer)))] - [boolean-field Bool $t;boolean id] - [byte-field Int $t;byte host;l2b] - [short-field Int $t;short host;l2s] - [int-field Int $t;int host;l2i] - [long-field Int $t;long id] - [float-field Frac $t;float host;d2f] - [double-field Frac $t;double id] - [char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)] - [string-field Text ($t;class "java.lang.String" (list)) id] + [boolean-field Bool $t.boolean id] + [byte-field Int $t.byte host.l2b] + [short-field Int $t.short host.l2s] + [int-field Int $t.int host.l2i] + [long-field Int $t.long id] + [float-field Frac $t.float host.d2f] + [double-field Frac $t.double id] + [char-field Nat $t.char (|>> nat-to-int host.l2i host.i2c)] + [string-field Text ($t.class "java.lang.String" (list)) id] ) (def: #export (fuse defs) - (-> (List $;Def) $;Def) + (-> (List $.Def) $.Def) (case defs - #;Nil + #.Nil id - (#;Cons singleton #;Nil) + (#.Cons singleton #.Nil) singleton - (#;Cons head tail) - (. (fuse tail) head))) + (#.Cons head tail) + (function.compose (fuse tail) head))) diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index e0c10feca..5f3711bbd 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -1,28 +1,29 @@ -(;module: +(.module: [lux #- char] (lux (control monad ["p" parser]) (data [maybe] ["e" error] text/format - (coll [list "L/" Functor<List>])) + (coll [list "list/" Functor<List>])) [host #+ do-to] [macro] (macro [code] - ["s" syntax #+ syntax:])) + ["s" syntax #+ syntax:]) + [function]) ["$" //] (// ["$t" type])) ## [Host] -(host;import #long java.lang.Object) -(host;import #long java.lang.String) +(host.import #long java/lang/Object) +(host.import #long java/lang/String) -(syntax: (declare [codes (p;many s;local-symbol)]) +(syntax: (declare [codes (p.many s.local-symbol)]) (|> codes - (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int))))) + (list/map (function [code] (` ((~' #static) (~ (code.local-symbol code)) (~' int))))) wrap)) -(`` (host;import org.objectweb.asm.Opcodes +(`` (host.import org/objectweb/asm/Opcodes (#static NOP int) ## Conversion @@ -89,13 +90,10 @@ (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN)) )) -(host;import org.objectweb.asm.FieldVisitor - (visitEnd [] void)) - -(host;import org.objectweb.asm.Label +(host.import org/objectweb/asm/Label (new [])) -(host;import org.objectweb.asm.MethodVisitor +(host.import org/objectweb/asm/MethodVisitor (visitCode [] void) (visitMaxs [int int] void) (visitEnd [] void) @@ -116,42 +114,42 @@ (def: #export make-label (Meta Label) (function [compiler] - (#e;Success [compiler (Label.new [])]))) + (#e.Success [compiler (Label::new [])]))) (def: #export (with-label action) - (-> (-> Label $;Inst) $;Inst) - (action (Label.new []))) + (-> (-> Label $.Inst) $.Inst) + (action (Label::new []))) (do-template [<name> <type> <prepare>] [(def: #export (<name> value) - (-> <type> $;Inst) + (-> <type> $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitLdcInsn [(<prepare> value)]))))] + (MethodVisitor::visitLdcInsn [(<prepare> value)]))))] [boolean Bool id] - [int Int host;l2i] + [int Int host.l2i] [long Int id] [double Frac id] - [char Nat (|>. nat-to-int host;l2i host;i2c)] + [char Nat (|>> nat-to-int host.l2i host.i2c)] [string Text id] ) -(syntax: (prefix [base s;local-symbol]) - (wrap (list (code;local-symbol (format "Opcodes." base))))) +(syntax: (prefix [base s.local-symbol]) + (wrap (list (code.local-symbol (format "Opcodes::" base))))) (def: #export NULL - $;Inst + $.Inst (function [visitor] (do-to visitor - (MethodVisitor.visitInsn [(prefix ACONST_NULL)])))) + (MethodVisitor::visitInsn [(prefix ACONST_NULL)])))) (do-template [<name>] [(def: #export <name> - $;Inst + $.Inst (function [visitor] (do-to visitor - (MethodVisitor.visitInsn [(prefix <name>)]))))] + (MethodVisitor::visitInsn [(prefix <name>)]))))] [NOP] @@ -209,10 +207,10 @@ (do-template [<name>] [(def: #export (<name> register) - (-> Nat $;Inst) + (-> Nat $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))] + (MethodVisitor::visitVarInsn [(prefix <name>) (nat-to-int register)]))))] [ILOAD] [LLOAD] [DLOAD] [ALOAD] [ISTORE] [LSTORE] [ASTORE] @@ -220,64 +218,64 @@ (do-template [<name> <inst>] [(def: #export (<name> class field type) - (-> Text Text $;Type $;Inst) + (-> Text Text $.Type $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))] + (MethodVisitor::visitFieldInsn [<inst> ($t.binary-name class) field ($t.descriptor type)]))))] - [GETSTATIC Opcodes.GETSTATIC] - [PUTSTATIC Opcodes.PUTSTATIC] + [GETSTATIC Opcodes::GETSTATIC] + [PUTSTATIC Opcodes::PUTSTATIC] - [PUTFIELD Opcodes.PUTFIELD] - [GETFIELD Opcodes.GETFIELD] + [PUTFIELD Opcodes::PUTFIELD] + [GETFIELD Opcodes::GETFIELD] ) (do-template [<name> <inst>] [(def: #export (<name> class) - (-> Text $;Inst) + (-> Text $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))] + (MethodVisitor::visitTypeInsn [<inst> ($t.binary-name class)]))))] - [CHECKCAST Opcodes.CHECKCAST] - [NEW Opcodes.NEW] - [INSTANCEOF Opcodes.INSTANCEOF] - [ANEWARRAY Opcodes.ANEWARRAY] + [CHECKCAST Opcodes::CHECKCAST] + [NEW Opcodes::NEW] + [INSTANCEOF Opcodes::INSTANCEOF] + [ANEWARRAY Opcodes::ANEWARRAY] ) (def: #export (NEWARRAY type) - (-> $;Primitive $;Inst) + (-> $.Primitive $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type - #$;Boolean Opcodes.T_BOOLEAN - #$;Byte Opcodes.T_BYTE - #$;Short Opcodes.T_SHORT - #$;Int Opcodes.T_INT - #$;Long Opcodes.T_LONG - #$;Float Opcodes.T_FLOAT - #$;Double Opcodes.T_DOUBLE - #$;Char Opcodes.T_CHAR)])))) + (MethodVisitor::visitIntInsn [Opcodes::NEWARRAY (case type + #$.Boolean Opcodes::T_BOOLEAN + #$.Byte Opcodes::T_BYTE + #$.Short Opcodes::T_SHORT + #$.Int Opcodes::T_INT + #$.Long Opcodes::T_LONG + #$.Float Opcodes::T_FLOAT + #$.Double Opcodes::T_DOUBLE + #$.Char Opcodes::T_CHAR)])))) (do-template [<name> <inst>] [(def: #export (<name> class method-name method-signature interface?) - (-> Text Text $;Method Bool $;Inst) + (-> Text Text $.Method Bool $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))] + (MethodVisitor::visitMethodInsn [<inst> ($t.binary-name class) method-name ($t.method-descriptor method-signature) interface?]))))] - [INVOKESTATIC Opcodes.INVOKESTATIC] - [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] - [INVOKESPECIAL Opcodes.INVOKESPECIAL] - [INVOKEINTERFACE Opcodes.INVOKEINTERFACE] + [INVOKESTATIC Opcodes::INVOKESTATIC] + [INVOKEVIRTUAL Opcodes::INVOKEVIRTUAL] + [INVOKESPECIAL Opcodes::INVOKESPECIAL] + [INVOKEINTERFACE Opcodes::INVOKEINTERFACE] ) (do-template [<name>] [(def: #export (<name> @where) - (-> $;Label $;Inst) + (-> $.Label $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))] + (MethodVisitor::visitJumpInsn [(prefix <name>) @where]))))] [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL] [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE] @@ -285,99 +283,99 @@ ) (def: #export (TABLESWITCH min max default labels) - (-> Int Int $;Label (List $;Label) $;Inst) + (-> Int Int $.Label (List $.Label) $.Inst) (function [visitor] - (let [num-labels (list;size labels) - labels-array (host;array Label num-labels) + (let [num-labels (list.size labels) + labels-array (host.array Label num-labels) _ (loop [idx +0] - (if (n.< num-labels idx) - (exec (host;array-write idx - (maybe;assume (list;nth idx labels)) + (if (n/< num-labels idx) + (exec (host.array-write idx + (maybe.assume (list.nth idx labels)) labels-array) - (recur (n.inc idx))) + (recur (n/inc idx))) []))] (do-to visitor - (MethodVisitor.visitTableSwitchInsn [min max default labels-array]))))) + (MethodVisitor::visitTableSwitchInsn [min max default labels-array]))))) (def: #export (try @from @to @handler exception) - (-> $;Label $;Label $;Label Text $;Inst) + (-> $.Label $.Label $.Label Text $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)])))) + (MethodVisitor::visitTryCatchBlock [@from @to @handler ($t.binary-name exception)])))) (def: #export (label @label) - (-> $;Label $;Inst) + (-> $.Label $.Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitLabel [@label])))) + (MethodVisitor::visitLabel [@label])))) (def: #export (array type) - (-> $;Type $;Inst) + (-> $.Type $.Inst) (case type - (#$;Primitive prim) + (#$.Primitive prim) (NEWARRAY prim) - (#$;Generic generic) + (#$.Generic generic) (let [elem-class (case generic - (#$;Class class params) - ($t;binary-name class) + (#$.Class class params) + ($t.binary-name class) _ - ($t;binary-name "java.lang.Object"))] + ($t.binary-name "java.lang.Object"))] (ANEWARRAY elem-class)) _ - (ANEWARRAY ($t;descriptor type)))) + (ANEWARRAY ($t.descriptor type)))) (def: (primitive-wrapper type) - (-> $;Primitive Text) + (-> $.Primitive Text) (case type - #$;Boolean "java.lang.Boolean" - #$;Byte "java.lang.Byte" - #$;Short "java.lang.Short" - #$;Int "java.lang.Integer" - #$;Long "java.lang.Long" - #$;Float "java.lang.Float" - #$;Double "java.lang.Double" - #$;Char "java.lang.Character")) + #$.Boolean "java.lang.Boolean" + #$.Byte "java.lang.Byte" + #$.Short "java.lang.Short" + #$.Int "java.lang.Integer" + #$.Long "java.lang.Long" + #$.Float "java.lang.Float" + #$.Double "java.lang.Double" + #$.Char "java.lang.Character")) (def: (primitive-unwrap type) - (-> $;Primitive Text) + (-> $.Primitive Text) (case type - #$;Boolean "booleanValue" - #$;Byte "byteValue" - #$;Short "shortValue" - #$;Int "intValue" - #$;Long "longValue" - #$;Float "floatValue" - #$;Double "doubleValue" - #$;Char "charValue")) + #$.Boolean "booleanValue" + #$.Byte "byteValue" + #$.Short "shortValue" + #$.Int "intValue" + #$.Long "longValue" + #$.Float "floatValue" + #$.Double "doubleValue" + #$.Char "charValue")) (def: #export (wrap type) - (-> $;Primitive $;Inst) + (-> $.Primitive $.Inst) (let [class (primitive-wrapper type)] - (|>. (INVOKESTATIC class "valueOf" - ($t;method (list (#$;Primitive type)) - (#;Some ($t;class class (list))) + (|>> (INVOKESTATIC class "valueOf" + ($t.method (list (#$.Primitive type)) + (#.Some ($t.class class (list))) (list)) false)))) (def: #export (unwrap type) - (-> $;Primitive $;Inst) + (-> $.Primitive $.Inst) (let [class (primitive-wrapper type)] - (|>. (CHECKCAST class) + (|>> (CHECKCAST class) (INVOKEVIRTUAL class (primitive-unwrap type) - ($t;method (list) (#;Some (#$;Primitive type)) (list)) + ($t.method (list) (#.Some (#$.Primitive type)) (list)) false)))) (def: #export (fuse insts) - (-> (List $;Inst) $;Inst) + (-> (List $.Inst) $.Inst) (case insts - #;Nil + #.Nil id - (#;Cons singleton #;Nil) + (#.Cons singleton #.Nil) singleton - (#;Cons head tail) - (. (fuse tail) head))) + (#.Cons head tail) + (function.compose (fuse tail) head))) diff --git a/new-luxc/source/luxc/lang/host/jvm/type.lux b/new-luxc/source/luxc/lang/host/jvm/type.lux index 03246540c..b29ffc4a0 100644 --- a/new-luxc/source/luxc/lang/host/jvm/type.lux +++ b/new-luxc/source/luxc/lang/host/jvm/type.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- char] (lux (data [text] text/format @@ -7,132 +7,132 @@ ## Types (do-template [<name> <primitive>] - [(def: #export <name> $;Type (#$;Primitive <primitive>))] - - [boolean #$;Boolean] - [byte #$;Byte] - [short #$;Short] - [int #$;Int] - [long #$;Long] - [float #$;Float] - [double #$;Double] - [char #$;Char] + [(def: #export <name> $.Type (#$.Primitive <primitive>))] + + [boolean #$.Boolean] + [byte #$.Byte] + [short #$.Short] + [int #$.Int] + [long #$.Long] + [float #$.Float] + [double #$.Double] + [char #$.Char] ) (def: #export (class name params) - (-> Text (List $;Generic) $;Type) - (#$;Generic (#$;Class name params))) + (-> Text (List $.Generic) $.Type) + (#$.Generic (#$.Class name params))) (def: #export (var name) - (-> Text $;Type) - (#$;Generic (#$;Var name))) + (-> Text $.Type) + (#$.Generic (#$.Var name))) (def: #export (wildcard bound) - (-> (Maybe [$;Bound $;Generic]) $;Type) - (#$;Generic (#$;Wildcard bound))) + (-> (Maybe [$.Bound $.Generic]) $.Type) + (#$.Generic (#$.Wildcard bound))) (def: #export (array depth elemT) - (-> Nat $;Type $;Type) + (-> Nat $.Type $.Type) (case depth +0 elemT - _ (#$;Array (array (n.dec depth) elemT)))) + _ (#$.Array (array (n/dec depth) elemT)))) (def: #export (binary-name class) (-> Text Text) - (text;replace-all "." "/" class)) + (text.replace-all "." "/" class)) (def: #export (descriptor type) - (-> $;Type Text) + (-> $.Type Text) (case type - (#$;Primitive prim) + (#$.Primitive prim) (case prim - #$;Boolean "Z" - #$;Byte "B" - #$;Short "S" - #$;Int "I" - #$;Long "J" - #$;Float "F" - #$;Double "D" - #$;Char "C") - - (#$;Array sub) + #$.Boolean "Z" + #$.Byte "B" + #$.Short "S" + #$.Int "I" + #$.Long "J" + #$.Float "F" + #$.Double "D" + #$.Char "C") + + (#$.Array sub) (format "[" (descriptor sub)) - (#$;Generic generic) + (#$.Generic generic) (case generic - (#$;Class class params) + (#$.Class class params) (format "L" (binary-name class) ";") - (^or (#$;Var name) (#$;Wildcard ?bound)) - (descriptor (#$;Generic (#$;Class "java.lang.Object" (list))))) + (^or (#$.Var name) (#$.Wildcard ?bound)) + (descriptor (#$.Generic (#$.Class "java.lang.Object" (list))))) )) (def: #export (signature type) - (-> $;Type Text) + (-> $.Type Text) (case type - (#$;Primitive prim) + (#$.Primitive prim) (case prim - #$;Boolean "Z" - #$;Byte "B" - #$;Short "S" - #$;Int "I" - #$;Long "J" - #$;Float "F" - #$;Double "D" - #$;Char "C") - - (#$;Array sub) + #$.Boolean "Z" + #$.Byte "B" + #$.Short "S" + #$.Int "I" + #$.Long "J" + #$.Float "F" + #$.Double "D" + #$.Char "C") + + (#$.Array sub) (format "[" (signature sub)) - (#$;Generic generic) + (#$.Generic generic) (case generic - (#$;Class class params) - (let [=params (if (list;empty? params) + (#$.Class class params) + (let [=params (if (list.empty? params) "" (format "<" (|> params - (list/map (|>. #$;Generic signature)) - (text;join-with "")) + (list/map (|>> #$.Generic signature)) + (text.join-with "")) ">"))] (format "L" (binary-name class) =params ";")) - (#$;Var name) + (#$.Var name) (format "T" name ";") - (#$;Wildcard #;None) + (#$.Wildcard #.None) "*" (^template [<tag> <prefix>] - (#$;Wildcard (#;Some [<tag> bound])) - (format <prefix> (signature (#$;Generic bound)))) - ([#$;Upper "+"] - [#$;Lower "-"])) + (#$.Wildcard (#.Some [<tag> bound])) + (format <prefix> (signature (#$.Generic bound)))) + ([#$.Upper "+"] + [#$.Lower "-"])) )) ## Methods (def: #export (method args return exceptions) - (-> (List $;Type) (Maybe $;Type) (List $;Generic) $;Method) - {#$;args args #$;return return #$;exceptions exceptions}) + (-> (List $.Type) (Maybe $.Type) (List $.Generic) $.Method) + {#$.args args #$.return return #$.exceptions exceptions}) (def: #export (method-descriptor method) - (-> $;Method Text) - (format "(" (text;join-with "" (list/map descriptor (get@ #$;args method))) ")" - (case (get@ #$;return method) - #;None + (-> $.Method Text) + (format "(" (text.join-with "" (list/map descriptor (get@ #$.args method))) ")" + (case (get@ #$.return method) + #.None "V" - (#;Some return) + (#.Some return) (descriptor return)))) (def: #export (method-signature method) - (-> $;Method Text) - (format "(" (|> (get@ #$;args method) (list/map signature) (text;join-with "")) ")" - (case (get@ #$;return method) - #;None + (-> $.Method Text) + (format "(" (|> (get@ #$.args method) (list/map signature) (text.join-with "")) ")" + (case (get@ #$.return method) + #.None "V" - (#;Some return) + (#.Some return) (signature return)) - (|> (get@ #$;exceptions method) - (list/map (|>. #$;Generic signature (format "^"))) - (text;join-with "")))) + (|> (get@ #$.exceptions method) + (list/map (|>> #$.Generic signature (format "^"))) + (text.join-with "")))) diff --git a/new-luxc/source/luxc/lang/macro.lux b/new-luxc/source/luxc/lang/macro.lux index 4885e21db..71b140c6e 100644 --- a/new-luxc/source/luxc/lang/macro.lux +++ b/new-luxc/source/luxc/lang/macro.lux @@ -1,37 +1,35 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data ["e" error]) [macro] [host]) - (luxc (lang [";L" host] - (translation [";T" common])))) + (luxc (lang [".L" host] + (translation [".T" common])))) -(for {"JVM" (as-is (host;import java.lang.reflect.Method +(for {"JVM" (as-is (host.import java/lang/reflect/Method (invoke [Object (Array Object)] #try Object)) - (host;import (java.lang.Class c) + (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)) + (host.import java/lang/Object) + (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))) + (|> (host.array (Class Object) +2) + (host.array-write +0 _object-class) + (host.array-write +1 _object-class))) (def: #export (expand macro inputs) (-> Macro (List Code) (Meta (List Code))) - (do macro;Monad<Meta> - [class (commonT;load-class hostL;function-class)] + (do macro.Monad<Meta> + [class (commonT.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)]) + (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)))))) }) diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux index f6cffa9c6..62e20fa9a 100644 --- a/new-luxc/source/luxc/lang/module.lux +++ b/new-luxc/source/luxc/lang/module.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -10,7 +10,7 @@ [macro] (macro [code])) (luxc ["&" lang] - (lang ["&;" scope]))) + (lang ["&." scope]))) (exception: #export Unknown-Module) (exception: #export Cannot-Declare-Tag-Twice) @@ -22,198 +22,198 @@ (def: (new-module hash) (-> Nat Module) - {#;module-hash hash - #;module-aliases (list) - #;defs (list) - #;imports (list) - #;tags (list) - #;types (list) - #;module-annotations (' {}) - #;module-state #;Active}) + {#.module-hash hash + #.module-aliases (list) + #.defs (list) + #.imports (list) + #.tags (list) + #.types (list) + #.module-annotations (' {}) + #.module-state #.Active}) (def: #export (set-annotations annotations) (-> Code (Meta Unit)) - (do macro;Monad<Meta> - [self macro;current-module-name] + (do macro.Monad<Meta> + [self macro.current-module-name] (function [compiler] - (#e;Success [(update@ #;modules - (&;pl-update self (set@ #;module-annotations annotations)) + (#e.Success [(update@ #.modules + (&.pl-update self (set@ #.module-annotations annotations)) compiler) []])))) (def: #export (import module) (-> Text (Meta Unit)) - (do macro;Monad<Meta> - [self macro;current-module-name] + (do macro.Monad<Meta> + [self macro.current-module-name] (function [compiler] - (#e;Success [(update@ #;modules - (&;pl-update self (update@ #;imports (|>. (#;Cons module)))) + (#e.Success [(update@ #.modules + (&.pl-update self (update@ #.imports (|>> (#.Cons module)))) compiler) []])))) (def: #export (alias alias module) (-> Text Text (Meta Unit)) - (do macro;Monad<Meta> - [self macro;current-module-name] + (do macro.Monad<Meta> + [self macro.current-module-name] (function [compiler] - (#e;Success [(update@ #;modules - (&;pl-update self (update@ #;module-aliases (: (-> (List [Text Text]) (List [Text Text])) - (|>. (#;Cons [alias module]))))) + (#e.Success [(update@ #.modules + (&.pl-update self (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) compiler) []])))) (def: #export (exists? module) (-> Text (Meta Bool)) (function [compiler] - (|> (get@ #;modules compiler) - (&;pl-get module) - (case> (#;Some _) true #;None false) - [compiler] #e;Success))) + (|> (get@ #.modules compiler) + (&.pl-get module) + (case> (#.Some _) true #.None false) + [compiler] #e.Success))) (def: #export (define (^@ full-name [module-name def-name]) definition) (-> Ident Def (Meta Unit)) (function [compiler] - (case (&;pl-get module-name (get@ #;modules compiler)) - (#;Some module) - (case (&;pl-get def-name (get@ #;defs module)) - #;None - (#e;Success [(update@ #;modules - (&;pl-put module-name - (update@ #;defs + (case (&.pl-get module-name (get@ #.modules compiler)) + (#.Some module) + (case (&.pl-get def-name (get@ #.defs module)) + #.None + (#e.Success [(update@ #.modules + (&.pl-put module-name + (update@ #.defs (: (-> (List [Text Def]) (List [Text Def])) - (|>. (#;Cons [def-name definition]))) + (|>> (#.Cons [def-name definition]))) module)) compiler) []]) - (#;Some already-existing) - ((&;throw Cannot-Define-More-Than-Once (%ident full-name)) compiler)) + (#.Some already-existing) + ((&.throw Cannot-Define-More-Than-Once (%ident full-name)) compiler)) - #;None - ((&;throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler)))) + #.None + ((&.throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler)))) (def: #export (create hash name) (-> Nat Text (Meta Module)) (function [compiler] (let [module (new-module hash)] - (#e;Success [(update@ #;modules - (&;pl-put name module) + (#e.Success [(update@ #.modules + (&.pl-put name module) compiler) module])))) (def: #export (with-module hash name action) (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [_ (create hash name) - output (&;with-current-module name + output (&.with-current-module name action) - module (macro;find-module name)] + module (macro.find-module name)] (wrap [module output]))) (do-template [<flagger> <asker> <tag> <description>] [(def: #export (<flagger> module-name) (-> Text (Meta Unit)) (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get module-name)) - (#;Some module) - (let [active? (case (get@ #;module-state module) - #;Active true + (case (|> compiler (get@ #.modules) (&.pl-get module-name)) + (#.Some module) + (let [active? (case (get@ #.module-state module) + #.Active true _ false)] (if active? - (#e;Success [(update@ #;modules - (&;pl-put module-name (set@ #;module-state <tag> module)) + (#e.Success [(update@ #.modules + (&.pl-put module-name (set@ #.module-state <tag> module)) compiler) []]) - ((&;throw Can-Only-Change-State-Of-Active-Module + ((&.throw Can-Only-Change-State-Of-Active-Module (format " Module: " module-name "\n" "Desired state: " <description>)) compiler))) - #;None - ((&;throw Unknown-Module module-name) compiler)))) + #.None + ((&.throw Unknown-Module module-name) compiler)))) (def: #export (<asker> module-name) (-> Text (Meta Bool)) (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get module-name)) - (#;Some module) - (#e;Success [compiler - (case (get@ #;module-state module) + (case (|> compiler (get@ #.modules) (&.pl-get module-name)) + (#.Some module) + (#e.Success [compiler + (case (get@ #.module-state module) <tag> true _ false)]) - #;None - ((&;throw Unknown-Module module-name) compiler)) + #.None + ((&.throw Unknown-Module module-name) compiler)) ))] - [flag-active! active? #;Active "Active"] - [flag-compiled! compiled? #;Compiled "Compiled"] - [flag-cached! cached? #;Cached "Cached"] + [flag-active! active? #.Active "Active"] + [flag-compiled! compiled? #.Compiled "Compiled"] + [flag-cached! cached? #.Cached "Cached"] ) (do-template [<name> <tag> <type>] [(def: (<name> module-name) (-> Text (Meta <type>)) (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get module-name)) - (#;Some module) - (#e;Success [compiler (get@ <tag> module)]) + (case (|> compiler (get@ #.modules) (&.pl-get module-name)) + (#.Some module) + (#e.Success [compiler (get@ <tag> module)]) - #;None - ((&;throw Unknown-Module module-name) compiler)) + #.None + ((&.throw Unknown-Module module-name) compiler)) ))] - [tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])] - [types-by-module #;types (List [Text [(List Ident) Bool Type]])] - [module-hash #;module-hash Nat] + [tags-by-module #.tags (List [Text [Nat (List Ident) Bool Type]])] + [types-by-module #.types (List [Text [(List Ident) Bool Type]])] + [module-hash #.module-hash Nat] ) (def: (ensure-undeclared-tags module-name tags) (-> Text (List Text) (Meta Unit)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [bindings (tags-by-module module-name) - _ (monad;map @ + _ (monad.map @ (function [tag] - (case (&;pl-get tag bindings) - #;None + (case (&.pl-get tag bindings) + #.None (wrap []) - (#;Some _) - (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n" + (#.Some _) + (&.throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n" " Tag: " tag)))) tags)] (wrap []))) (def: #export (declare-tags tags exported? type) (-> (List Text) Bool Type (Meta Unit)) - (do macro;Monad<Meta> - [current-module macro;current-module-name + (do macro.Monad<Meta> + [current-module macro.current-module-name [type-module type-name] (case type - (#;Named type-ident _) + (#.Named type-ident _) (wrap type-ident) _ - (&;throw Cannot-Declare-Tags-For-Unnamed-Type - (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + (&.throw Cannot-Declare-Tags-For-Unnamed-Type + (format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n" "Type: " (%type type)))) _ (ensure-undeclared-tags current-module tags) - _ (&;assert Cannot-Declare-Tags-For-Foreign-Type - (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + _ (&.assert Cannot-Declare-Tags-For-Foreign-Type + (format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n" "Type: " (%type type)) (text/= current-module type-module))] (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl-get current-module)) - (#;Some module) - (let [namespaced-tags (list/map (|>. [current-module]) tags)] - (#e;Success [(update@ #;modules - (&;pl-update current-module - (|>. (update@ #;tags (function [tag-bindings] + (case (|> compiler (get@ #.modules) (&.pl-get current-module)) + (#.Some module) + (let [namespaced-tags (list/map (|>> [current-module]) tags)] + (#e.Success [(update@ #.modules + (&.pl-update current-module + (|>> (update@ #.tags (function [tag-bindings] (list/fold (function [[idx tag] table] - (&;pl-put tag [idx namespaced-tags exported? type] table)) + (&.pl-put tag [idx namespaced-tags exported? type] table)) tag-bindings - (list;enumerate tags)))) - (update@ #;types (&;pl-put type-name [namespaced-tags exported? type])))) + (list.enumerate tags)))) + (update@ #.types (&.pl-put type-name [namespaced-tags exported? type])))) compiler) []])) - #;None - ((&;throw Unknown-Module current-module) compiler))))) + #.None + ((&.throw Unknown-Module current-module) compiler))))) diff --git a/new-luxc/source/luxc/lang/scope.lux b/new-luxc/source/luxc/lang/scope.lux index 8bc61e722..8dcdce6af 100644 --- a/new-luxc/source/luxc/lang/scope.lux +++ b/new-luxc/source/luxc/lang/scope.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) (data [text "text/" Eq<Text>] @@ -9,7 +9,7 @@ (coll [list "list/" Functor<List> Fold<List> Monoid<List>])) [macro]) (luxc ["&" lang] - (lang [";L" variable #+ Variable]))) + (lang [".L" variable #+ Variable]))) (type: Locals (Bindings Text [Type Nat])) (type: Captured (Bindings Text [Type Ref])) @@ -17,35 +17,35 @@ (def: (is-local? name scope) (-> Text Scope Bool) (|> scope - (get@ [#;locals #;mappings]) - (&;pl-contains? name))) + (get@ [#.locals #.mappings]) + (&.pl-contains? name))) (def: (get-local name scope) (-> Text Scope (Maybe [Type Ref])) (|> scope - (get@ [#;locals #;mappings]) - (&;pl-get name) + (get@ [#.locals #.mappings]) + (&.pl-get name) (maybe/map (function [[type value]] - [type (#;Local value)])))) + [type (#.Local value)])))) (def: (is-captured? name scope) (-> Text Scope Bool) (|> scope - (get@ [#;captured #;mappings]) - (&;pl-contains? name))) + (get@ [#.captured #.mappings]) + (&.pl-contains? name))) (def: (get-captured name scope) (-> Text Scope (Maybe [Type Ref])) (loop [idx +0 - mappings (get@ [#;captured #;mappings] scope)] + mappings (get@ [#.captured #.mappings] scope)] (case mappings - #;Nil - #;None + #.Nil + #.None - (#;Cons [_name [_source-type _source-ref]] mappings') + (#.Cons [_name [_source-type _source-ref]] mappings') (if (text/= name _name) - (#;Some [_source-type (#;Captured idx)]) - (recur (n.inc idx) mappings'))))) + (#.Some [_source-type (#.Captured idx)]) + (recur (n/inc idx) mappings'))))) (def: (is-ref? name scope) (-> Text Scope Bool) @@ -55,8 +55,8 @@ (def: (get-ref name scope) (-> Text Scope (Maybe [Type Ref])) (case (get-local name scope) - (#;Some type) - (#;Some type) + (#.Some type) + (#.Some type) _ (get-captured name scope))) @@ -65,68 +65,68 @@ (-> Text (Meta (Maybe [Type Ref]))) (function [compiler] (let [[inner outer] (|> compiler - (get@ #;scopes) - (list;split-with (|>. (is-ref? name) not)))] + (get@ #.scopes) + (list.split-with (|>> (is-ref? name) not)))] (case outer - #;Nil - (#;Right [compiler #;None]) + #.Nil + (#.Right [compiler #.None]) - (#;Cons top-outer _) - (let [[ref-type init-ref] (maybe;default (undefined) + (#.Cons top-outer _) + (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] - [(#;Captured (get@ [#;captured #;counter] scope)) - (#;Cons (update@ #;captured + [(#.Captured (get@ [#.captured #.counter] scope)) + (#.Cons (update@ #.captured (: (-> Captured Captured) - (|>. (update@ #;counter n.inc) - (update@ #;mappings (&;pl-put name [ref-type (product;left ref+inner)])))) + (|>> (update@ #.counter n/inc) + (update@ #.mappings (&.pl-put name [ref-type (product.left ref+inner)])))) scope) - (product;right ref+inner))])) - [init-ref #;Nil] - (list;reverse inner)) + (product.right ref+inner))])) + [init-ref #.Nil] + (list.reverse inner)) scopes (list/compose inner' outer)] - (#;Right [(set@ #;scopes scopes compiler) - (#;Some [ref-type ref])])) + (#.Right [(set@ #.scopes scopes compiler) + (#.Some [ref-type ref])])) )))) (def: #export (with-local [name type] action) (All [a] (-> [Text Type] (Meta a) (Meta a))) (function [compiler] - (case (get@ #;scopes compiler) - (#;Cons head tail) - (let [old-mappings (get@ [#;locals #;mappings] head) - new-var-id (get@ [#;locals #;counter] head) - new-head (update@ #;locals + (case (get@ #.scopes compiler) + (#.Cons head tail) + (let [old-mappings (get@ [#.locals #.mappings] head) + new-var-id (get@ [#.locals #.counter] head) + new-head (update@ #.locals (: (-> Locals Locals) - (|>. (update@ #;counter n.inc) - (update@ #;mappings (&;pl-put name [type new-var-id])))) + (|>> (update@ #.counter n/inc) + (update@ #.mappings (&.pl-put name [type new-var-id])))) head)] - (case (macro;run' (set@ #;scopes (#;Cons new-head tail) compiler) + (case (macro.run' (set@ #.scopes (#.Cons new-head tail) compiler) action) - (#e;Success [compiler' output]) - (case (get@ #;scopes compiler') - (#;Cons head' tail') - (let [scopes' (#;Cons (set@ #;locals (get@ #;locals head) head') + (#e.Success [compiler' output]) + (case (get@ #.scopes compiler') + (#.Cons head' tail') + (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') tail')] - (#e;Success [(set@ #;scopes scopes' compiler') + (#e.Success [(set@ #.scopes scopes' compiler') output])) _ - (error! "Invalid scope alteration.")) + (error! "Invalid scope alteration/")) - (#e;Error error) - (#e;Error error))) + (#e.Error error) + (#e.Error error))) _ - (#e;Error "Cannot create local binding without a scope.")) + (#e.Error "Cannot create local binding without a scope.")) )) (do-template [<name> <val-type>] [(def: <name> (Bindings Text [Type <val-type>]) - {#;counter +0 - #;mappings (list)})] + {#.counter +0 + #.mappings (list)})] [init-locals Nat] [init-captured Ref] @@ -134,29 +134,29 @@ (def: (scope parent-name child-name) (-> (List Text) Text Scope) - {#;name (list& child-name parent-name) - #;inner +0 - #;locals init-locals - #;captured init-captured}) + {#.name (list& child-name parent-name) + #.inner +0 + #.locals init-locals + #.captured init-captured}) (def: #export (with-scope name action) (All [a] (-> Text (Meta a) (Meta a))) (function [compiler] - (let [parent-name (case (get@ #;scopes compiler) - #;Nil + (let [parent-name (case (get@ #.scopes compiler) + #.Nil (list) - (#;Cons top _) - (get@ #;name top))] - (case (action (update@ #;scopes - (|>. (#;Cons (scope parent-name name))) + (#.Cons top _) + (get@ #.name top))] + (case (action (update@ #.scopes + (|>> (#.Cons (scope parent-name name))) compiler)) - (#e;Error error) - (#e;Error error) + (#e.Error error) + (#e.Error error) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;scopes - (|>. list;tail (maybe;default (list))) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.scopes + (|>> list.tail (maybe.default (list))) compiler') output]) )) @@ -165,9 +165,9 @@ (def: #export next-local (Meta Nat) (function [compiler] - (case (get@ #;scopes compiler) - #;Nil - (#e;Error "Cannot get next reference when there is no scope.") + (case (get@ #.scopes compiler) + #.Nil + (#e.Error "Cannot get next reference when there is no scope.") - (#;Cons top _) - (#e;Success [compiler (get@ [#;locals #;counter] top)])))) + (#.Cons top _) + (#e.Success [compiler (get@ [#.locals #.counter] top)])))) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index 3207c41b4..33c8aa063 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux) (def: #export Arity Nat) diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index c35483dd8..ab4820b30 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (data [bool "bool/" Eq<Bool>] [text "text/" Eq<Text>] @@ -6,54 +6,54 @@ [number] (coll [list "list/" Fold<List> Monoid<List>])) (macro [code "code/" Eq<Code>])) - (luxc (lang [";L" variable #+ Variable] + (luxc (lang [".L" variable #+ Variable] ["la" analysis] ["ls" synthesis] - (synthesis [";S" function])))) + (synthesis [".S" function])))) -(def: popPS ls;Path (' ("lux case pop"))) +(def: popPS ls.Path (' ("lux case pop"))) (def: (path' arity num-locals pattern) - (-> ls;Arity Nat la;Pattern [Nat (List ls;Path)]) + (-> ls.Arity Nat la.Pattern [Nat (List ls.Path)]) (case pattern (^code ("lux case tuple" [(~@ membersP)])) (case membersP - #;Nil + #.Nil [num-locals (list popPS)] - (#;Cons singletonP #;Nil) + (#.Cons singletonP #.Nil) (path' arity num-locals singletonP) - (#;Cons _) - (let [last-idx (n.dec (list;size membersP)) - [_ output] (list/fold (: (-> la;Pattern [Nat [Nat (List ls;Path)]] [Nat [Nat (List ls;Path)]]) + (#.Cons _) + (let [last-idx (n/dec (list.size membersP)) + [_ output] (list/fold (: (-> la.Pattern [Nat [Nat (List ls.Path)]] [Nat [Nat (List ls.Path)]]) (function [current-pattern [current-idx num-locals' next]] (let [[num-locals'' current-path] (path' arity num-locals' current-pattern)] - [(n.dec current-idx) + [(n/dec current-idx) num-locals'' - (|> (list (if (n.= last-idx current-idx) - (` ("lux case tuple right" (~ (code;nat current-idx)))) - (` ("lux case tuple left" (~ (code;nat current-idx)))))) + (|> (list (if (n/= last-idx current-idx) + (` ("lux case tuple right" (~ (code.nat current-idx)))) + (` ("lux case tuple left" (~ (code.nat current-idx)))))) (list/compose current-path) (list/compose next))]))) [last-idx num-locals (list popPS)] - (list;reverse membersP))] + (list.reverse membersP))] output)) - (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) + (^code ("lux case variant" (~ [_ (#.Nat tag)]) (~ [_ (#.Nat num-tags)]) (~ memberP))) (let [[num-locals' member-path] (path' arity num-locals memberP)] - [num-locals' (|> (list (if (n.= (n.dec num-tags) tag) - (` ("lux case variant right" (~ (code;nat tag)))) - (` ("lux case variant left" (~ (code;nat tag)))))) + [num-locals' (|> (list (if (n/= (n/dec num-tags) tag) + (` ("lux case variant right" (~ (code.nat tag)))) + (` ("lux case variant left" (~ (code.nat tag)))))) (list/compose member-path) (list& popPS))]) - (^code ("lux case bind" (~ [_ (#;Nat register)]))) - [(n.inc num-locals) + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + [(n/inc num-locals) (list popPS - (` ("lux case bind" (~ (code;nat (if (functionS;nested? arity) - (n.+ (n.dec arity) register) + (` ("lux case bind" (~ (code.nat (if (functionS.nested? arity) + (n/+ (n/dec arity) register) register))))))] _ @@ -61,18 +61,18 @@ (list popPS pattern)])) (def: (clean-unnecessary-pops paths) - (-> (List ls;Path) (List ls;Path)) + (-> (List ls.Path) (List ls.Path)) (case paths - (#;Cons path paths') + (#.Cons path paths') (if (is popPS path) (clean-unnecessary-pops paths') paths) - #;Nil + #.Nil paths)) (def: #export (path arity num-locals synthesize pattern bodyA) - (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) la;Pattern la;Analysis ls;Path) + (-> ls.Arity Nat (-> Nat la.Analysis ls.Synthesis) la.Pattern la.Analysis ls.Path) (let [[num-locals' pieces] (path' arity num-locals pattern)] (|> pieces clean-unnecessary-pops @@ -81,7 +81,7 @@ (` ("lux case exec" (~ (synthesize num-locals' bodyA)))))))) (def: #export (weave leftP rightP) - (-> ls;Path ls;Path ls;Path) + (-> ls.Path ls.Path ls.Path) (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))] (case [leftP rightP] (^ [(^code ("lux case seq" (~ preL) (~ postL))) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index aaa2cf2c7..d3fbfcb58 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control ["p" parser]) (data [maybe] @@ -12,82 +12,82 @@ ["s" syntax])) (luxc (lang ["la" analysis] ["ls" synthesis] - (synthesis [";S" case] - [";S" function] - [";S" loop]) - [";L" variable #+ Variable]) + (synthesis [".S" case] + [".S" function] + [".S" loop]) + [".L" variable #+ Variable]) )) (def: init-env (List Variable) (list)) -(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>)) +(def: init-resolver (Dict Int Int) (dict.new number.Hash<Int>)) (def: (prepare-body inner-arity arity body) - (-> ls;Arity ls;Arity ls;Synthesis ls;Synthesis) - (if (functionS;nested? inner-arity) + (-> ls.Arity ls.Arity ls.Synthesis ls.Synthesis) + (if (functionS.nested? inner-arity) body - (loopS;reify-recursion arity body))) + (loopS.reify-recursion arity body))) (def: (let$ register inputS bodyS) - (-> Nat ls;Synthesis ls;Synthesis ls;Synthesis) - (` ("lux let" (~ (code;nat register)) (~ inputS) (~ bodyS)))) + (-> Nat ls.Synthesis ls.Synthesis ls.Synthesis) + (` ("lux let" (~ (code.nat register)) (~ inputS) (~ bodyS)))) (def: (if$ testS thenS elseS) - (-> ls;Synthesis ls;Synthesis ls;Synthesis ls;Synthesis) + (-> ls.Synthesis ls.Synthesis ls.Synthesis ls.Synthesis) (` ("lux if" (~ testS) (~ thenS) (~ elseS)))) (def: (function$ arity environment body) - (-> ls;Arity (List Variable) ls;Synthesis ls;Synthesis) - (` ("lux function" (~ (code;nat arity)) - [(~@ (list/map code;int environment))] + (-> ls.Arity (List Variable) ls.Synthesis ls.Synthesis) + (` ("lux function" (~ (code.nat arity)) + [(~@ (list/map code.int environment))] (~ body)))) (def: (variant$ tag last? valueS) - (-> Nat Bool ls;Synthesis ls;Synthesis) - (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS)))) + (-> Nat Bool ls.Synthesis ls.Synthesis) + (` ((~ (code.nat tag)) (~ (code.bool last?)) (~ valueS)))) (def: (var$ var) - (-> Variable ls;Synthesis) - (` ((~ (code;int var))))) + (-> Variable ls.Synthesis) + (` ((~ (code.int var))))) (def: (procedure$ name argsS) - (-> Text (List ls;Synthesis) ls;Synthesis) - (` ((~ (code;text name)) (~@ argsS)))) + (-> Text (List ls.Synthesis) ls.Synthesis) + (` ((~ (code.text name)) (~@ argsS)))) (def: (call$ funcS argsS) - (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis) + (-> ls.Synthesis (List ls.Synthesis) ls.Synthesis) (` ("lux call" (~ funcS) (~@ argsS)))) (def: (synthesize-case arity num-locals synthesize inputA branchesA) - (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) - la;Analysis (List [la;Pattern la;Analysis]) - ls;Synthesis) + (-> ls.Arity Nat (-> Nat la.Analysis ls.Synthesis) + la.Analysis (List [la.Pattern la.Analysis]) + ls.Synthesis) (let [inputS (synthesize num-locals inputA)] - (case (list;reverse branchesA) - (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)]))) - (^code ((~ [_ (#;Int var)])))])) - (not (variableL;captured? var)) - (n.= input-register (variableL;local-register var))) + (case (list.reverse branchesA) + (^multi (^ (list [(^code ("lux case bind" (~ [_ (#.Nat input-register)]))) + (^code ((~ [_ (#.Int var)])))])) + (not (variableL.captured? var)) + (n/= input-register (variableL.local-register var))) inputS - (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA])) - (let$ (if (functionS;nested? arity) - (n.+ (n.dec arity) register) + (^ (list [(^code ("lux case bind" (~ [_ (#.Nat register)]))) bodyA])) + (let$ (if (functionS.nested? arity) + (n/+ (n/dec arity) register) register) inputS - (synthesize (n.inc num-locals) bodyA)) + (synthesize (n/inc num-locals) bodyA)) (^or (^ (list [(^code true) thenA] [(^code false) elseA])) (^ (list [(^code false) elseA] [(^code true) thenA]))) (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA)) - (#;Cons [lastP lastA] prevsPA) - (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) - (caseS;path arity num-locals synthesize)) - pathS (list/fold caseS;weave + (#.Cons [lastP lastA] prevsPA) + (let [transform-branch (: (-> la.Pattern la.Analysis ls.Path) + (caseS.path arity num-locals synthesize)) + pathS (list/fold caseS.weave (transform-branch lastP lastA) - (list/map (product;uncurry transform-branch) prevsPA))] + (list/map (product.uncurry transform-branch) prevsPA))] (` ("lux case" (~ inputS) (~ pathS)))) _ @@ -95,17 +95,17 @@ ))) (def: (synthesize-apply synthesize num-locals exprA) - (-> (-> la;Analysis ls;Synthesis) Nat la;Analysis ls;Synthesis) - (let [[funcA argsA] (functionS;unfold-apply exprA) + (-> (-> la.Analysis ls.Synthesis) Nat la.Analysis ls.Synthesis) + (let [[funcA argsA] (functionS.unfold-apply exprA) funcS (synthesize funcA) argsS (list/map synthesize argsA)] (case funcS - (^multi (^code ("lux function" (~ [_ (#;Nat _arity)]) [(~@ _env)] (~ _bodyS))) - (and (n.= _arity (list;size argsS)) - (not (loopS;contains-self-reference? _bodyS))) - [(s;run _env (p;some s;int)) (#e;Success _env)]) - (` ("lux loop" (~ (code;nat (n.inc num-locals))) [(~@ argsS)] - (~ (loopS;adjust _env num-locals _bodyS)))) + (^multi (^code ("lux function" (~ [_ (#.Nat _arity)]) [(~@ _env)] (~ _bodyS))) + (and (n/= _arity (list.size argsS)) + (not (loopS.contains-self-reference? _bodyS))) + [(s.run _env (p.some s.int)) (#e.Success _env)]) + (` ("lux loop" (~ (code.nat (n/inc num-locals))) [(~@ argsS)] + (~ (loopS.adjust _env num-locals _bodyS)))) (^code ("lux call" (~ funcS') (~@ argsS'))) (call$ funcS' (list/compose argsS' argsS)) @@ -114,7 +114,7 @@ (call$ funcS argsS)))) (def: #export (synthesize expressionA) - (-> la;Analysis ls;Synthesis) + (-> la.Analysis ls.Synthesis) (loop [arity +0 resolver init-resolver direct? false @@ -123,63 +123,63 @@ (case expressionA (^code [(~ _left) (~ _right)]) (` [(~@ (list/map (recur arity resolver false num-locals) - (la;unfold-tuple expressionA)))]) + (la.unfold-tuple expressionA)))]) (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) - (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))] + (let [[tag last? value] (maybe.assume (la.unfold-variant expressionA))] (variant$ tag last? (recur arity resolver false num-locals value))) - (^code ((~ [_ (#;Int var)]))) - (if (variableL;local? var) - (if (functionS;nested? arity) - (if (variableL;self? var) - (call$ (var$ 0) (|> (list;n.range +1 (n.dec arity)) - (list/map (|>. variableL;local code;int (~) () (`))))) - (var$ (functionS;adjust-var arity var))) + (^code ((~ [_ (#.Int var)]))) + (if (variableL.local? var) + (if (functionS.nested? arity) + (if (variableL.self? var) + (call$ (var$ 0) (|> (list.n/range +1 (n/dec arity)) + (list/map (|>> variableL.local code.int (~) () (`))))) + (var$ (functionS.adjust-var arity var))) (var$ var)) - (var$ (maybe;default var (dict;get var resolver)))) + (var$ (maybe.default var (dict.get var resolver)))) - (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) + (^code ("lux case" (~ inputA) (~ [_ (#.Record branchesA)]))) (synthesize-case arity num-locals (recur arity resolver false) inputA branchesA) (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) - [(s;run scope (p;some s;int)) (#e;Success raw-env)]) + [(s.run scope (p.some s.int)) (#e.Success raw-env)]) (let [function-arity (if direct? - (n.inc arity) + (n/inc arity) +1) env (list/map (function [closure] - (case (dict;get closure resolver) - (#;Some resolved) - (if (and (variableL;local? resolved) - (functionS;nested? arity) - (|> resolved variableL;local-register (n.>= arity))) - (functionS;adjust-var arity resolved) + (case (dict.get closure resolver) + (#.Some resolved) + (if (and (variableL.local? resolved) + (functionS.nested? arity) + (|> resolved variableL.local-register (n/>= arity))) + (functionS.adjust-var arity resolved) resolved) - #;None - (if (and (variableL;local? closure) - (functionS;nested? arity)) - (functionS;adjust-var arity closure) + #.None + (if (and (variableL.local? closure) + (functionS.nested? arity)) + (functionS.adjust-var arity closure) closure))) raw-env) env-vars (: (List Variable) (case raw-env - #;Nil (list) - _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured)))) - resolver' (if (and (functionS;nested? function-arity) + #.Nil (list) + _ (|> (list.size raw-env) n/dec (list.n/range +0) (list/map variableL.captured)))) + resolver' (if (and (functionS.nested? function-arity) direct?) (list/fold (function [[from to] resolver'] - (dict;put from to resolver')) + (dict.put from to resolver')) init-resolver - (list;zip2 env-vars env)) + (list.zip2 env-vars env)) (list/fold (function [var resolver'] - (dict;put var var resolver')) + (dict.put var var resolver')) init-resolver env-vars))] (case (recur function-arity resolver' true function-arity bodyA) - (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat unmerged-arity)] env' bodyS'))]) - (let [merged-arity (n.inc unmerged-arity)] + (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat unmerged-arity)] env' bodyS'))]) + (let [merged-arity (n/inc unmerged-arity)] (function$ merged-arity env (prepare-body function-arity merged-arity bodyS'))) @@ -189,7 +189,7 @@ (^code ("lux apply" (~@ _))) (synthesize-apply (recur arity resolver false num-locals) num-locals expressionA) - (^code ((~ [_ (#;Text name)]) (~@ args))) + (^code ((~ [_ (#.Text name)]) (~@ args))) (procedure$ name (list/map (recur arity resolver false num-locals) args)) _ diff --git a/new-luxc/source/luxc/lang/synthesis/function.lux b/new-luxc/source/luxc/lang/synthesis/function.lux index 52aee9a49..25dd75aff 100644 --- a/new-luxc/source/luxc/lang/synthesis/function.lux +++ b/new-luxc/source/luxc/lang/synthesis/function.lux @@ -1,29 +1,29 @@ -(;module: +(.module: lux (luxc (lang ["la" analysis] ["ls" synthesis] - [";L" variable #+ Variable]))) + [".L" variable #+ Variable]))) (do-template [<name> <comp> <ref>] [(def: #export (<name> arity) - (-> ls;Arity Bool) + (-> ls.Arity Bool) (<comp> <ref> arity))] - [nested? n.> +1] - [top? n.= +0] + [nested? n/> +1] + [top? n/= +0] ) (def: #export (adjust-var outer var) - (-> ls;Arity Variable Variable) - (|> outer n.dec nat-to-int (i.+ var))) + (-> ls.Arity Variable Variable) + (|> outer n/dec nat-to-int (i/+ var))) (def: #export (unfold-apply apply) - (-> la;Analysis [la;Analysis (List la;Analysis)]) + (-> la.Analysis [la.Analysis (List la.Analysis)]) (loop [apply apply args (list)] (case apply (^code ("lux apply" (~ arg) (~ func))) - (recur func (#;Cons arg args)) + (recur func (#.Cons arg args)) _ [apply args]))) diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux index a5da743d5..0510e2377 100644 --- a/new-luxc/source/luxc/lang/synthesis/loop.lux +++ b/new-luxc/source/luxc/lang/synthesis/loop.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser]) @@ -7,101 +7,101 @@ (macro [code] [syntax])) (luxc (lang ["ls" synthesis] - [";L" variable #+ Variable Register]))) + [".L" variable #+ Variable Register]))) (def: #export (contains-self-reference? exprS) - (-> ls;Synthesis Bool) + (-> ls.Synthesis Bool) (case exprS - (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] memberS))]) + (^ [_ (#.Form (list [_ (#.Nat tag)] [_ (#.Bool last?)] memberS))]) (contains-self-reference? memberS) - [_ (#;Tuple membersS)] - (list;any? contains-self-reference? membersS) + [_ (#.Tuple membersS)] + (list.any? contains-self-reference? membersS) - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (variableL;self? var) + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (variableL.self? var) - (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case")] inputS pathS))]) (or (contains-self-reference? inputS) (loop [pathS pathS] (case pathS - (^or (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) - (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))])) + (^or (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftS rightS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftS rightS))])) (or (recur leftS) (recur rightS)) - (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) (contains-self-reference? bodyS) _ false))) - (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) - (list;any? (function [captured] + (^ [_ (#.Form (list [_ (#.Text "lux function")] arity [_ (#.Tuple environment)] bodyS))]) + (list.any? (function [captured] (case captured - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (variableL;self? var) + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (variableL.self? var) _ false)) environment) - (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) + (^ [_ (#.Form (list& [_ (#.Text "lux call")] funcS argsS))]) (or (contains-self-reference? funcS) - (list;any? contains-self-reference? argsS)) + (list.any? contains-self-reference? argsS)) - (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (^ [_ (#.Form (list [_ (#.Text "lux let")] register inputS bodyS))]) (or (contains-self-reference? inputS) (contains-self-reference? bodyS)) - (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))]) (or (contains-self-reference? inputS) (contains-self-reference? thenS) (contains-self-reference? elseS)) - (^ [_ (#;Form (list [_ (#;Text "lux loop")] offset [_ (#;Tuple initsS)] bodyS))]) - (or (list;any? contains-self-reference? initsS) + (^ [_ (#.Form (list [_ (#.Text "lux loop")] offset [_ (#.Tuple initsS)] bodyS))]) + (or (list.any? contains-self-reference? initsS) (contains-self-reference? bodyS)) - (^or (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) - (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])) - (list;any? contains-self-reference? argsS) + (^or (^ [_ (#.Form (list& [_ (#.Text "lux recur")] argsS))]) + (^ [_ (#.Form (list& [_ (#.Text procedure)] argsS))])) + (list.any? contains-self-reference? argsS) _ false )) (def: #export (reify-recursion arity exprS) - (-> Nat ls;Synthesis ls;Synthesis) + (-> Nat ls.Synthesis ls.Synthesis) (loop [exprS exprS] (case exprS - (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case")] inputS pathS))]) (` ("lux case" (~ inputS) (~ (let [reify-recursion' recur] (loop [pathS pathS] (case pathS - (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftS rightS))]) (` ("lux case alt" (~ (recur leftS)) (~ (recur rightS)))) - (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftS rightS))]) (` ("lux case seq" (~ leftS) (~ (recur rightS)))) - (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) (` ("lux case exec" (~ (reify-recursion' bodyS)))) _ pathS)))))) - (^multi (^ [_ (#;Form (list& [_ (#;Text "lux call")] - [_ (#;Form (list [_ (#;Int 0)]))] + (^multi (^ [_ (#.Form (list& [_ (#.Text "lux call")] + [_ (#.Form (list [_ (#.Int 0)]))] argsS))]) - (n.= arity (list;size argsS))) + (n/= arity (list.size argsS))) (` ("lux recur" (~@ argsS))) - (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (^ [_ (#.Form (list [_ (#.Text "lux let")] register inputS bodyS))]) (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS)))) - (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))]) (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS)))) _ @@ -109,15 +109,15 @@ ))) (def: #export (adjust env offset exprS) - (-> (List Variable) Register ls;Synthesis ls;Synthesis) + (-> (List Variable) Register ls.Synthesis ls.Synthesis) (let [resolve-captured (: (-> Variable Variable) (function [var] - (let [idx (|> var (i.* -1) int-to-nat n.dec)] - (|> env (list;nth idx) maybe;assume))))] + (let [idx (|> var (i/* -1) int-to-nat n/dec)] + (|> env (list.nth idx) maybe.assume))))] (loop [exprS exprS] (case exprS - (^code ((~ [_ (#;Nat tag)]) (~ last?) (~ valueS))) - (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) + (^code ((~ [_ (#.Nat tag)]) (~ last?) (~ valueS))) + (` ((~ (code.nat tag)) (~ last?) (~ (recur valueS)))) (^code [(~@ members)]) (` [(~@ (list/map recur members))]) @@ -128,15 +128,15 @@ (loop [pathS pathS] (case pathS (^template [<pattern>] - (^ [_ (#;Form (list [_ (#;Text <pattern>)] leftS rightS))]) + (^ [_ (#.Form (list [_ (#.Text <pattern>)] leftS rightS))]) (` (<pattern> (~ (recur leftS)) (~ (recur rightS))))) (["lux case alt"] ["lux case seq"]) - (^code ("lux case bind" (~ [_ (#;Nat register)]))) - (` ("lux case bind" (~ (code;nat (n.+ offset register))))) + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (` ("lux case bind" (~ (code.nat (n/+ offset register))))) - (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) (` ("lux case exec" (~ (adjust' bodyS)))) _ @@ -146,42 +146,42 @@ (` ("lux function" (~ arity) [(~@ (list/map (function [_var] (case _var - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (` ((~ (code;int (resolve-captured var))))) + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (` ((~ (code.int (resolve-captured var))))) _ _var)) environment))] (~ bodyS))) - (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) + (^ [_ (#.Form (list& [_ (#.Text "lux call")] funcS argsS))]) (` ("lux call" (~ (recur funcS)) (~@ (list/map recur argsS)))) - (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (^ [_ (#.Form (list& [_ (#.Text "lux recur")] argsS))]) (` ("lux recur" (~@ (list/map recur argsS)))) - (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ bodyS))) - (` ("lux let" (~ (code;nat (n.+ offset register))) + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ bodyS))) + (` ("lux let" (~ (code.nat (n/+ offset register))) (~ (recur inputS)) (~ (recur bodyS)))) - (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))]) (` ("lux if" (~ (recur inputS)) (~ (recur thenS)) (~ (recur elseS)))) - (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat loop-offset)] [_ (#;Tuple initsS)] bodyS))]) - (` ("lux loop" (~ (code;nat (n.+ offset loop-offset))) + (^ [_ (#.Form (list [_ (#.Text "lux loop")] [_ (#.Nat loop-offset)] [_ (#.Tuple initsS)] bodyS))]) + (` ("lux loop" (~ (code.nat (n/+ offset loop-offset))) [(~@ (list/map recur initsS))] (~ (recur bodyS)))) - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (if (variableL;captured? var) - (` ((~ (code;int (resolve-captured var))))) - (` ((~ (code;int (|> offset nat-to-int (i.+ var))))))) + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (if (variableL.captured? var) + (` ((~ (code.int (resolve-captured var))))) + (` ((~ (code.int (|> offset nat-to-int (i/+ var))))))) - (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) - (` ((~ (code;text procedure)) (~@ (list/map recur argsS)))) + (^ [_ (#.Form (list& [_ (#.Text procedure)] argsS))]) + (` ((~ (code.text procedure)) (~@ (list/map recur argsS)))) _ exprS diff --git a/new-luxc/source/luxc/lang/synthesis/variable.lux b/new-luxc/source/luxc/lang/synthesis/variable.lux index 3ce9f2678..b1988018d 100644 --- a/new-luxc/source/luxc/lang/synthesis/variable.lux +++ b/new-luxc/source/luxc/lang/synthesis/variable.lux @@ -1,96 +1,96 @@ -(;module: +(.module: lux (lux (data [number] (coll [list "list/" Fold<List> Monoid<List>] ["s" set]))) (luxc (lang ["la" analysis] ["ls" synthesis] - [";L" variable #+ Variable]))) + [".L" variable #+ Variable]))) (def: (bound-vars path) - (-> ls;Path (List Variable)) + (-> ls.Path (List Variable)) (case path - (#ls;BindP register) + (#ls.BindP register) (list (nat-to-int register)) - (^or (#ls;SeqP pre post) (#ls;AltP pre post)) + (^or (#ls.SeqP pre post) (#ls.AltP pre post)) (list/compose (bound-vars pre) (bound-vars post)) _ (list))) (def: (path-bodies path) - (-> ls;Path (List ls;Synthesis)) + (-> ls.Path (List ls.Synthesis)) (case path - (#ls;ExecP body) + (#ls.ExecP body) (list body) - (#ls;SeqP pre post) + (#ls.SeqP pre post) (path-bodies post) - (#ls;AltP pre post) + (#ls.AltP pre post) (list/compose (path-bodies pre) (path-bodies post)) _ (list))) (def: (non-arg? arity var) - (-> ls;Arity Variable Bool) - (and (variableL;local? var) - (n.> arity (int-to-nat var)))) + (-> ls.Arity Variable Bool) + (and (variableL.local? var) + (n/> arity (int-to-nat var)))) -(type: Tracker (s;Set Variable)) +(type: Tracker (s.Set Variable)) -(def: init-tracker Tracker (s;new number;Hash<Int>)) +(def: init-tracker Tracker (s.new number.Hash<Int>)) (def: (unused-vars current-arity bound exprS) - (-> ls;Arity (List Variable) ls;Synthesis (List Variable)) + (-> ls.Arity (List Variable) ls.Synthesis (List Variable)) (let [tracker (loop [exprS exprS - tracker (list/fold s;add init-tracker bound)] + tracker (list/fold s.add init-tracker bound)] (case exprS - (#ls;Variable var) + (#ls.Variable var) (if (non-arg? current-arity var) - (s;remove var tracker) + (s.remove var tracker) tracker) - (#ls;Variant tag last? memberS) + (#ls.Variant tag last? memberS) (recur memberS tracker) - (#ls;Tuple membersS) + (#ls.Tuple membersS) (list/fold recur tracker membersS) - (#ls;Call funcS argsS) + (#ls.Call funcS argsS) (list/fold recur (recur funcS tracker) argsS) - (^or (#ls;Recur argsS) - (#ls;Procedure name argsS)) + (^or (#ls.Recur argsS) + (#ls.Procedure name argsS)) (list/fold recur tracker argsS) - (#ls;Let offset inputS outputS) + (#ls.Let offset inputS outputS) (|> tracker (recur inputS) (recur outputS)) - (#ls;If testS thenS elseS) + (#ls.If testS thenS elseS) (|> tracker (recur testS) (recur thenS) (recur elseS)) - (#ls;Loop offset initsS bodyS) + (#ls.Loop offset initsS bodyS) (recur bodyS (list/fold recur tracker initsS)) - (#ls;Case inputS outputPS) - (let [tracker' (list/fold s;add + (#ls.Case inputS outputPS) + (let [tracker' (list/fold s.add (recur inputS tracker) (bound-vars outputPS))] (list/fold recur tracker' (path-bodies outputPS))) - (#ls;Function arity env bodyS) - (list/fold s;remove tracker env) + (#ls.Function arity env bodyS) + (list/fold s.remove tracker env) _ tracker ))] - (s;to-list tracker))) + (s.to-list tracker))) ## (def: (optimize-register-use current-arity [pathS bodyS]) -## (-> ls;Arity [ls;Path ls;Synthesis] [ls;Path ls;Synthesis]) +## (-> ls.Arity [ls.Path ls.Synthesis] [ls.Path ls.Synthesis]) ## (let [bound (bound-vars pathS) ## unused (unused-vars current-arity bound bodyS) ## adjusted (adjust-vars unused bound)] diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 86b9842b6..07f1fe533 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -16,160 +16,160 @@ [io #+ IO Process io] (world [file #+ File])) (luxc ["&" lang] - ["&;" io] - (lang [";L" module] - [";L" host] - [";L" macro] + ["&." io] + (lang [".L" module] + [".L" host] + [".L" macro] (host ["$" jvm]) - (analysis [";A" expression] - [";A" common]) - (synthesis [";S" expression]) - (translation [";T" runtime] - [";T" statement] - [";T" common] - [";T" expression] - [";T" eval] - [";T" imports]) - ["&;" eval]) + (analysis [".A" expression] + [".A" common]) + (synthesis [".S" expression]) + (translation [".T" runtime] + [".T" statement] + [".T" common] + [".T" expression] + [".T" eval] + [".T" imports]) + ["&." eval]) )) (def: analyse - (&;Analyser) - (expressionA;analyser &eval;eval)) + (&.Analyser) + (expressionA.analyser &eval.eval)) (exception: #export Macro-Expansion-Failed) (exception: #export Unrecognized-Statement) (exception: #export Invalid-Alias) (def: (process-annotations annsC) - (-> Code (Meta [$;Inst Code])) - (do macro;Monad<Meta> - [[_ annsA] (&;with-scope - (&;with-type Code + (-> Code (Meta [$.Inst Code])) + (do macro.Monad<Meta> + [[_ annsA] (&.with-scope + (&.with-type Code (analyse annsC))) - annsI (expressionT;translate (expressionS;synthesize annsA)) - annsV (evalT;eval annsI)] + annsI (expressionT.translate (expressionS.synthesize annsA)) + annsV (evalT.eval annsI)] (wrap [annsI (:! Code annsV)]))) (def: (switch-compiler new-compiler) (-> Compiler (Meta Aliases)) (function [old-compiler] - ((do macro;Monad<Meta> - [this macro;current-module] - (wrap (|> this (get@ #;module-aliases) (dict;from-list text;Hash<Text>) (: Aliases)))) + ((do macro.Monad<Meta> + [this macro.current-module] + (wrap (|> this (get@ #.module-aliases) (dict.from-list text.Hash<Text>) (: Aliases)))) new-compiler))) (def: (ensure-valid-alias def-name annotations value) (-> Text Code Code (Meta Unit)) (case [annotations value] - (^multi [[_ (#;Record pairs)] [_ (#;Symbol _)]] - (|> pairs list;size (n.= +1))) - (:: macro;Monad<Meta> wrap []) + (^multi [[_ (#.Record pairs)] [_ (#.Symbol _)]] + (|> pairs list.size (n/= +1))) + (:: macro.Monad<Meta> wrap []) _ - (&;throw Invalid-Alias def-name))) + (&.throw Invalid-Alias def-name))) (def: #export (translate translate-module aliases code) (-> (-> Text Compiler (Process Compiler)) Aliases Code (Meta Aliases)) (case code - (^code ((~ [_ (#;Symbol macro-name)]) (~@ args))) - (do macro;Monad<Meta> - [?macro (&;with-error-tracking - (macro;find-macro macro-name))] + (^code ((~ [_ (#.Symbol macro-name)]) (~@ args))) + (do macro.Monad<Meta> + [?macro (&.with-error-tracking + (macro.find-macro macro-name))] (case ?macro - (#;Some macro) + (#.Some macro) (do @ [expansion (: (Meta (List Code)) (function [compiler] - (case (macroL;expand macro args compiler) - (#e;Error error) - ((&;throw Macro-Expansion-Failed error) compiler) + (case (macroL.expand macro args compiler) + (#e.Error error) + ((&.throw Macro-Expansion-Failed error) compiler) output output))) - expansion-aliases (monad;map @ (translate translate-module aliases) expansion)] - (if (dict;empty? aliases) + expansion-aliases (monad.map @ (translate translate-module aliases) expansion)] + (if (dict.empty? aliases) (loop [expansion-aliases expansion-aliases] (case expansion-aliases - #;Nil + #.Nil (wrap aliases) - (#;Cons head tail) - (if (dict;empty? head) + (#.Cons head tail) + (if (dict.empty? head) (recur tail) (wrap head)))) (wrap aliases))) - #;None - (&;throw Unrecognized-Statement (%code code)))) + #.None + (&.throw Unrecognized-Statement (%code code)))) - (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ annsC))) - (hostL;with-context def-name - (&;with-fresh-type-env - (do macro;Monad<Meta> + (^code ("lux def" (~ [_ (#.Symbol ["" def-name])]) (~ valueC) (~ annsC))) + (hostL.with-context def-name + (&.with-fresh-type-env + (do macro.Monad<Meta> [[annsI annsV] (process-annotations annsC)] - (case (macro;get-symbol-ann (ident-for #;alias) annsV) - (#;Some real-def) + (case (macro.get-symbol-ann (ident-for #.alias) annsV) + (#.Some real-def) (do @ [_ (ensure-valid-alias def-name annsV valueC) - _ (&;with-scope - (statementT;translate-def def-name Void id annsI annsV))] + _ (&.with-scope + (statementT.translate-def def-name Void id annsI annsV))] (wrap aliases)) - #;None + #.None (do @ - [[_ valueT valueA] (&;with-scope - (if (macro;type? (:! Code annsV)) + [[_ valueT valueA] (&.with-scope + (if (macro.type? (:! Code annsV)) (do @ - [valueA (&;with-type Type + [valueA (&.with-type Type (analyse valueC))] (wrap [Type valueA])) - (commonA;with-unknown-type + (commonA.with-unknown-type (analyse valueC)))) - valueT (&;with-type-env - (tc;clean valueT)) + valueT (&.with-type-env + (tc.clean valueT)) ## #let [_ (if (or (text/= "string~" def-name)) ## (log! (format "{" def-name "}\n" ## " TYPE: " (%type valueT) "\n" ## " ANALYSIS: " (%code valueA) "\n" - ## "SYNTHESIS: " (%code (expressionS;synthesize valueA)))) + ## "SYNTHESIS: " (%code (expressionS.synthesize valueA)))) ## [])] - valueI (expressionT;translate (expressionS;synthesize valueA)) - _ (&;with-scope - (statementT;translate-def def-name valueT valueI annsI annsV))] + valueI (expressionT.translate (expressionS.synthesize valueA)) + _ (&.with-scope + (statementT.translate-def def-name valueT valueI annsI annsV))] (wrap aliases)))))) (^code ("lux module" (~ annsC))) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [[annsI annsV] (process-annotations annsC) - process (importsT;translate-imports translate-module annsV)] - (case (io;run process) - (#e;Success compiler') + process (importsT.translate-imports translate-module annsV)] + (case (io.run process) + (#e.Success compiler') (switch-compiler compiler') - (#e;Error error) - (macro;fail error))) + (#e.Error error) + (macro.fail error))) - (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC))) - (do macro;Monad<Meta> - [[_ programA] (&;with-scope - (&;with-type (type (io;IO Unit)) + (^code ("lux program" (~ [_ (#.Symbol ["" program-args])]) (~ programC))) + (do macro.Monad<Meta> + [[_ programA] (&.with-scope + (&.with-type (type (io.IO Unit)) (analyse programC))) - programI (expressionT;translate (expressionS;synthesize programA)) - _ (statementT;translate-program program-args programI)] + programI (expressionT.translate (expressionS.synthesize programA)) + _ (statementT.translate-program program-args programI)] (wrap aliases)) _ - (&;throw Unrecognized-Statement (%code code)))) + (&.throw Unrecognized-Statement (%code code)))) (def: (forgive-eof action) (-> (Meta Unit) (Meta Unit)) (function [compiler] (case (action compiler) - (#e;Error error) - (if (ex;match? syntax;End-Of-File error) - (#e;Success [compiler []]) - (#e;Error error)) + (#e.Error error) + (if (ex.match? syntax.End-Of-File error) + (#e.Success [compiler []]) + (#e.Error error)) output output))) @@ -178,103 +178,103 @@ (def: (with-active-compilation [module-name file-name source-code] action) (All [a] (-> [Text Text Text] (Meta a) (Meta a))) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [#let [init-cursor [file-name +1 +0]] - output (&;with-source-code [init-cursor +0 source-code] + output (&.with-source-code [init-cursor +0 source-code] action) - _ (moduleL;flag-compiled! module-name)] + _ (moduleL.flag-compiled! module-name)] (wrap output))) (def: (read current-module aliases) (-> Text Aliases (Meta Code)) (function [compiler] - (case (syntax;read current-module aliases (get@ #;source compiler)) - (#e;Error error) - (#e;Error error) + (case (syntax.read current-module aliases (get@ #.source compiler)) + (#e.Error error) + (#e.Error error) - (#e;Success [source' output]) - (#e;Success [(set@ #;source source' compiler) + (#e.Success [source' output]) + (#e.Success [(set@ #.source source' compiler) output])))) (def: #export (translate-module source-dirs target-dir module-name compiler) (-> (List File) File Text Compiler (Process Compiler)) - (do io;Monad<Process> - [## _ (&io;prepare-module target-dir module-name) - [file-name file-content] (&io;read-module source-dirs module-name) + (do io.Monad<Process> + [## _ (&io.prepare-module target-dir module-name) + [file-name file-content] (&io.read-module source-dirs module-name) #let [module-hash (text/hash file-content) translate-module (translate-module source-dirs target-dir)]] - (case (macro;run' compiler - (do macro;Monad<Meta> - [[_ artifacts _] (moduleL;with-module module-hash module-name - (commonT;with-artifacts + (case (macro.run' compiler + (do macro.Monad<Meta> + [[_ artifacts _] (moduleL.with-module module-hash module-name + (commonT.with-artifacts (with-active-compilation [module-name file-name file-content] (forgive-eof (loop [aliases (: Aliases - (dict;new text;Hash<Text>))] + (dict.new text.Hash<Text>))] (do @ [code (read module-name aliases) #let [[cursor _] code] - aliases' (&;with-cursor cursor + aliases' (&.with-cursor cursor (translate translate-module aliases code))] (forgive-eof (recur aliases'))))))))] (wrap artifacts))) - (#e;Success [compiler artifacts]) + (#e.Success [compiler artifacts]) (do @ - [## _ (monad;map @ (function [[class-name class-bytecode]] - ## (&io;write-file target-dir class-name class-bytecode)) - ## (dict;entries artifacts)) + [## _ (monad.map @ (function [[class-name class-bytecode]] + ## (&io.write-file target-dir class-name class-bytecode)) + ## (dict.entries artifacts)) ] (wrap compiler)) - (#e;Error error) - (io;fail error)))) + (#e.Error error) + (io.fail error)))) (def: init-cursor Cursor ["" +1 +0]) (def: #export init-type-context Type-Context - {#;ex-counter +0 - #;var-counter +0 - #;var-bindings (list)}) + {#.ex-counter +0 + #.var-counter +0 + #.var-bindings (list)}) (def: #export init-info Info - {#;target (for {"JVM" "JVM" + {#.target (for {"JVM" "JVM" "JS" "JS"}) - #;version &;version - #;mode #;Build}) + #.version &.version + #.mode #.Build}) (def: #export (init-compiler host) - (-> commonT;Host Compiler) - {#;info init-info - #;source [init-cursor +0 ""] - #;cursor init-cursor - #;current-module #;None - #;modules (list) - #;scopes (list) - #;type-context init-type-context - #;expected #;None - #;seed +0 - #;scope-type-vars (list) - #;host (:! Void host)}) + (-> commonT.Host Compiler) + {#.info init-info + #.source [init-cursor +0 ""] + #.cursor init-cursor + #.current-module #.None + #.modules (list) + #.scopes (list) + #.type-context init-type-context + #.expected #.None + #.seed +0 + #.scope-type-vars (list) + #.host (:! Void host)}) (def: #export (translate-program sources target program) - (-> (List File) File Text (T;Task Unit)) - (do T;Monad<Task> - [compiler (|> (case (runtimeT;translate (init-compiler (io;run hostL;init-host))) - (#e;Error error) - (T;fail error) + (-> (List File) File Text (T.Task Unit)) + (do T.Monad<Task> + [compiler (|> (case (runtimeT.translate (init-compiler (io.run hostL.init-host))) + (#e.Error error) + (T.fail error) - (#e;Success [compiler [runtime-bc function-bc]]) + (#e.Success [compiler [runtime-bc function-bc]]) (do @ - [_ (&io;prepare-target target) - _ (&io;write-file target (format hostL;runtime-class ".class") runtime-bc) - _ (&io;write-file target (format hostL;function-class ".class") function-bc)] + [_ (&io.prepare-target target) + _ (&io.write-file target (format hostL.runtime-class ".class") runtime-bc) + _ (&io.write-file target (format hostL.function-class ".class") function-bc)] (wrap compiler))) - (: (T;Task Compiler)) - (:: @ map (|>. (translate-module sources target prelude) P;future)) (:: @ join) - (:: @ map (|>. (translate-module sources target program) P;future)) (:: @ join)) + (: (T.Task Compiler)) + (:: @ map (|>> (translate-module sources target prelude) P.future)) (:: @ join) + (:: @ map (|>> (translate-module sources target program) P.future)) (:: @ join)) #let [_ (log! "Compilation complete!")]] (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index 3363e007c..b693f50b8 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -1,130 +1,130 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) (data text/format) [macro "macro/" Monad<Meta>]) (luxc ["_" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$i" inst])) ["ls" synthesis])) [//runtime]) -(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: (pop-altI stack-depth) - (-> Nat $;Inst) + (-> Nat $.Inst) (case stack-depth +0 id - +1 $i;POP - +2 $i;POP2 - _ ## (n.> +2) - (|>. $i;POP2 - (pop-altI (n.- +2 stack-depth))))) + +1 $i.POP + +2 $i.POP2 + _ ## (n/> +2) + (|>> $i.POP2 + (pop-altI (n/- +2 stack-depth))))) (def: peekI - $;Inst - (|>. $i;DUP - ($i;INVOKESTATIC hostL;runtime-class + $.Inst + (|>> $i.DUP + ($i.INVOKESTATIC hostL.runtime-class "pm_peek" - ($t;method (list //runtime;$Stack) - (#;Some $Object) + ($t.method (list //runtime.$Stack) + (#.Some $Object) (list)) false))) (def: popI - $;Inst - (|>. ($i;INVOKESTATIC hostL;runtime-class + $.Inst + (|>> ($i.INVOKESTATIC hostL.runtime-class "pm_pop" - ($t;method (list //runtime;$Stack) - (#;Some //runtime;$Stack) + ($t.method (list //runtime.$Stack) + (#.Some //runtime.$Stack) (list)) false))) (def: pushI - $;Inst - (|>. ($i;INVOKESTATIC hostL;runtime-class + $.Inst + (|>> ($i.INVOKESTATIC hostL.runtime-class "pm_push" - ($t;method (list //runtime;$Stack $Object) - (#;Some //runtime;$Stack) + ($t.method (list //runtime.$Stack $Object) + (#.Some //runtime.$Stack) (list)) false))) (exception: #export Unrecognized-Path) (def: (translate-path' translate stack-depth @else @end path) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat $;Label $;Label ls;Path (Meta $;Inst)) + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat $.Label $.Label ls.Path (Meta $.Inst)) (case path - (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) - (do macro;Monad<Meta> + (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) + (do macro.Monad<Meta> [bodyI (translate bodyS)] - (wrap (|>. (pop-altI stack-depth) + (wrap (|>> (pop-altI stack-depth) bodyI - ($i;GOTO @end)))) + ($i.GOTO @end)))) - (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) + (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))]) (macro/wrap popI) - (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) - (macro/wrap (|>. peekI - ($i;ASTORE register))) + (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))]) + (macro/wrap (|>> peekI + ($i.ASTORE register))) - [_ (#;Bool value)] - (macro/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] - (|>. peekI - ($i;unwrap #$;Boolean) + [_ (#.Bool value)] + (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)] + (|>> peekI + ($i.unwrap #$.Boolean) (jumpI @else)))) (^template [<tag> <prep>] [_ (<tag> value)] - (macro/wrap (|>. peekI - ($i;unwrap #$;Long) - ($i;long (|> value <prep>)) - $i;LCMP - ($i;IFNE @else)))) - ([#;Nat (:! Int)] - [#;Int (: Int)] - [#;Deg (:! Int)]) - - [_ (#;Frac value)] - (macro/wrap (|>. peekI - ($i;unwrap #$;Double) - ($i;double value) - $i;DCMPL - ($i;IFNE @else))) + (macro/wrap (|>> peekI + ($i.unwrap #$.Long) + ($i.long (|> value <prep>)) + $i.LCMP + ($i.IFNE @else)))) + ([#.Nat (:! Int)] + [#.Int (: Int)] + [#.Deg (:! Int)]) + + [_ (#.Frac value)] + (macro/wrap (|>> peekI + ($i.unwrap #$.Double) + ($i.double value) + $i.DCMPL + ($i.IFNE @else))) - [_ (#;Text value)] - (macro/wrap (|>. peekI - ($i;string value) - ($i;INVOKEVIRTUAL "java.lang.Object" + [_ (#.Text value)] + (macro/wrap (|>> peekI + ($i.string value) + ($i.INVOKEVIRTUAL "java.lang.Object" "equals" - ($t;method (list $Object) - (#;Some $t;boolean) + ($t.method (list $Object) + (#.Some $t.boolean) (list)) false) - ($i;IFEQ @else))) + ($i.IFEQ @else))) (^template [<special> <method>] - (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))]) + (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.Nat idx)]))]) (macro/wrap (case idx +0 - (|>. peekI - ($i;CHECKCAST ($t;descriptor //runtime;$Tuple)) - ($i;int 0) - $i;AALOAD + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) + ($i.int 0) + $i.AALOAD pushI) _ - (|>. peekI - ($i;CHECKCAST ($t;descriptor //runtime;$Tuple)) - ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC hostL;runtime-class + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) + ($i.int (nat-to-int idx)) + ($i.INVOKESTATIC hostL.runtime-class <method> - ($t;method (list //runtime;$Tuple $t;int) - (#;Some $Object) + ($t.method (list //runtime.$Tuple $t.int) + (#.Some $Object) (list)) false) pushI)))) @@ -132,99 +132,99 @@ ["lux case tuple right" "pm_right"]) (^template [<special> <flag>] - (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))]) - (macro/wrap (<| $i;with-label (function [@success]) - $i;with-label (function [@fail]) - (|>. peekI - ($i;CHECKCAST ($t;descriptor //runtime;$Variant)) - ($i;int (nat-to-int idx)) + (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.Nat idx)]))]) + (macro/wrap (<| $i.with-label (function [@success]) + $i.with-label (function [@fail]) + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Variant)) + ($i.int (nat-to-int idx)) <flag> - ($i;INVOKESTATIC hostL;runtime-class "pm_variant" - ($t;method (list //runtime;$Variant //runtime;$Tag //runtime;$Flag) - (#;Some //runtime;$Datum) + ($i.INVOKESTATIC hostL.runtime-class "pm_variant" + ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag) + (#.Some //runtime.$Datum) (list)) false) - $i;DUP - ($i;IFNULL @fail) - ($i;GOTO @success) - ($i;label @fail) - $i;POP - ($i;GOTO @else) - ($i;label @success) + $i.DUP + ($i.IFNULL @fail) + ($i.GOTO @success) + ($i.label @fail) + $i.POP + ($i.GOTO @else) + ($i.label @success) pushI)))) - (["lux case variant left" $i;NULL] - ["lux case variant right" ($i;string "")]) + (["lux case variant left" $i.NULL] + ["lux case variant right" ($i.string "")]) - (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) - (do macro;Monad<Meta> + (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))]) + (do macro.Monad<Meta> [leftI (translate-path' translate stack-depth @else @end leftP) rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>. leftI + (wrap (|>> leftI rightI))) - (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) - (do macro;Monad<Meta> - [@alt-else $i;make-label - leftI (translate-path' translate (n.inc stack-depth) @alt-else @end leftP) + (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))]) + (do macro.Monad<Meta> + [@alt-else $i.make-label + leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP) rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>. $i;DUP + (wrap (|>> $i.DUP leftI - ($i;label @alt-else) - $i;POP + ($i.label @alt-else) + $i.POP rightI))) _ - (_;throw Unrecognized-Path (%code path)))) + (_.throw Unrecognized-Path (%code path)))) (def: (translate-path translate path @end) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Path $;Label (Meta $;Inst)) - (do macro;Monad<Meta> - [@else $i;make-label + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Path $.Label (Meta $.Inst)) + (do macro.Monad<Meta> + [@else $i.make-label pathI (translate-path' translate +1 @else @end path)] - (wrap (|>. pathI - ($i;label @else) - $i;POP - ($i;INVOKESTATIC hostL;runtime-class + (wrap (|>> pathI + ($i.label @else) + $i.POP + ($i.INVOKESTATIC hostL.runtime-class "pm_fail" - ($t;method (list) #;None (list)) + ($t.method (list) #.None (list)) false) - $i;NULL - ($i;GOTO @end))))) + $i.NULL + ($i.GOTO @end))))) (def: #export (translate-if testI thenI elseI) - (-> $;Inst $;Inst $;Inst $;Inst) - (<| $i;with-label (function [@else]) - $i;with-label (function [@end]) - (|>. testI - ($i;unwrap #$;Boolean) - ($i;IFEQ @else) + (-> $.Inst $.Inst $.Inst $.Inst) + (<| $i.with-label (function [@else]) + $i.with-label (function [@end]) + (|>> testI + ($i.unwrap #$.Boolean) + ($i.IFEQ @else) thenI - ($i;GOTO @end) - ($i;label @else) + ($i.GOTO @end) + ($i.label @else) elseI - ($i;label @end)))) + ($i.label @end)))) (def: #export (translate-case translate valueS path) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Synthesis ls;Path (Meta $;Inst)) - (do macro;Monad<Meta> - [@end $i;make-label + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis ls.Path (Meta $.Inst)) + (do macro.Monad<Meta> + [@end $i.make-label valueI (translate valueS) pathI (translate-path translate path @end)] - (wrap (|>. valueI - $i;NULL - $i;SWAP + (wrap (|>> valueI + $i.NULL + $i.SWAP pushI pathI - ($i;label @end))))) + ($i.label @end))))) (def: #export (translate-let translate register inputS exprS) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) - (do macro;Monad<Meta> + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat ls.Synthesis ls.Synthesis (Meta $.Inst)) + (do macro.Monad<Meta> [inputI (translate inputS) exprI (translate exprS)] - (wrap (|>. inputI - ($i;ASTORE register) + (wrap (|>> inputI + ($i.ASTORE register) exprI)))) diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux index 7a16a749a..b75b0672b 100644 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- function] (lux (control ["ex" exception #+ exception:]) [io] @@ -10,22 +10,22 @@ [host] (world [blob #+ Blob] [file #+ File])) - (luxc (lang [";L" variable #+ Register] + (luxc (lang [".L" variable #+ Register] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst]))))) -(host;import org.objectweb.asm.Opcodes +(host.import org/objectweb/asm/Opcodes (#static V1_6 int)) -(host;import org.objectweb.asm.Label) +(host.import org/objectweb/asm/Label) -(host;import java.lang.Object) +(host.import java/lang/Object) -(host;import (java.lang.Class a)) +(host.import (java/lang/Class a)) -(host;import java.lang.ClassLoader +(host.import java/lang/ClassLoader (loadClass [String] (Class Object))) (type: #export Bytecode Blob) @@ -48,57 +48,57 @@ (def: #export (with-artifacts action) (All [a] (-> (Meta a) (Meta [Artifacts a]))) - (;function [compiler] - (case (action (update@ #;host - (|>. (:! Host) - (set@ #artifacts (dict;new text;Hash<Text>)) + (.function [compiler] + (case (action (update@ #.host + (|>> (:! Host) + (set@ #artifacts (dict.new text.Hash<Text>)) (:! Void)) compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! Host) - (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts))) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts))) (:! Void)) compiler') - [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts)) + [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts)) output]]) - (#e;Error error) - (#e;Error error)))) + (#e.Error error) + (#e.Error error)))) (def: #export (record-artifact name content) (-> Text Blob (Meta Unit)) - (;function [compiler] - (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name)) - (ex;throw Cannot-Overwrite-Artifact name) - (#e;Success [(update@ #;host - (|>. (:! Host) - (update@ #artifacts (dict;put name content)) + (.function [compiler] + (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name)) + (ex.throw Cannot-Overwrite-Artifact name) + (#e.Success [(update@ #.host + (|>> (:! Host) + (update@ #artifacts (dict.put name content)) (:! Void)) compiler) []])))) (def: #export (store-class name byte-code) (-> Text Bytecode (Meta Unit)) - (;function [compiler] - (let [store (|> (get@ #;host compiler) + (.function [compiler] + (let [store (|> (get@ #.host compiler) (:! Host) (get@ #store))] - (if (dict;contains? name (|> store atom;read io;run)) - (ex;throw Class-Already-Stored name) - (#e;Success [compiler (io;run (atom;update (dict;put name byte-code) store))]) + (if (dict.contains? name (|> store atom.read io.run)) + (ex.throw Class-Already-Stored name) + (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))]) )))) (def: #export (load-class name) (-> Text (Meta (Class Object))) - (;function [compiler] - (let [host (:! Host (get@ #;host compiler)) - store (|> host (get@ #store) atom;read io;run)] - (if (dict;contains? name store) - (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) - (ex;throw Unknown-Class name))))) + (.function [compiler] + (let [host (:! Host (get@ #.host compiler)) + store (|> host (get@ #store) atom.read io.run)] + (if (dict.contains? name store) + (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) + (ex.throw Unknown-Class name))))) -(def: #export bytecode-version Int Opcodes.V1_6) +## (def: #export bytecode-version Int Opcodes::V1_6) (def: #export value-field Text "_value") -(def: #export $Object $;Type ($t;class "java.lang.Object" (list))) +(def: #export $Object $.Type ($t.class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux index 6b9ee9743..9cce16a49 100644 --- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/eval.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) (data [text] @@ -12,72 +12,36 @@ ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])) + (translation [".T" common])) )) -(host;import java.lang.Object) -(host;import java.lang.String) - -(host;import java.lang.reflect.Field +(host.import java/lang/reflect/Field (get [Object] Object)) -(host;import (java.lang.Class a) +(host.import (java/lang/Class a) (getField [String] Field)) -(host;import org.objectweb.asm.Opcodes - (#static ACC_PUBLIC int) - (#static ACC_SUPER int) - (#static ACC_FINAL int) - (#static ACC_STATIC int) - (#static PUTSTATIC int) - (#static RETURN int) - (#static V1_6 int) - ) - -(host;import org.objectweb.asm.MethodVisitor - (visitCode [] void) - (visitEnd [] void) - (visitLdcInsn [Object] void) - (visitFieldInsn [int String String String] void) - (visitInsn [int] void) - (visitMaxs [int int] void)) - -(host;import org.objectweb.asm.FieldVisitor - (visitEnd [] void)) - -(host;import org.objectweb.asm.ClassWriter - (#static COMPUTE_MAXS int) - (new [int]) - (visit [int int String String String (Array String)] void) - (visitEnd [] void) - (visitField [int String String String Object] FieldVisitor) - (visitMethod [int String String String (Array String)] MethodVisitor) - (toByteArray [] (Array byte))) - (def: #export (eval valueI) - (-> $;Inst (Meta Top)) - (do macro;Monad<Meta> - [current-module macro;current-module-name - class-name (:: @ map %code (macro;gensym (format current-module "/eval"))) - #let [store-name (text;replace-all "/" "." class-name) - writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) - (ClassWriter.visit [commonT;bytecode-version - (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER) - class-name - (host;null) - "java/lang/Object" - (host;null)])) - ($d;field #$;Public ($_ $;++F $;finalF $;staticF) - commonT;value-field commonT;$Object) - ($d;method #$;Public ($_ $;++M $;staticM $;strictM) - "<clinit>" - ($t;method (list) #;None (list)) - (|>. valueI - ($i;PUTSTATIC store-name commonT;value-field commonT;$Object) - $i;RETURN))) - bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] - _ (commonT;store-class store-name bytecode) - class (commonT;load-class store-name)] + (-> $.Inst (Meta Top)) + (do macro.Monad<Meta> + [current-module macro.current-module-name + class-name (:: @ map %code (macro.gensym (format current-module "/eval"))) + #let [store-name (text.replace-all "/" "." class-name) + bytecode ($d.class #$.V1_6 + #$.Public $.noneC + class-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.field #$.Public ($_ $.++F $.finalF $.staticF) + commonT.value-field commonT.$Object) + ($d.method #$.Public ($_ $.++M $.staticM $.strictM) + "<clinit>" + ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC store-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class store-name bytecode) + class (commonT.load-class store-name)] (wrap (|> class - (Class.getField [commonT;value-field]) - (Field.get (host;null)))))) + (Class::getField [commonT.value-field]) + (Field::get (host.null)))))) diff --git a/new-luxc/source/luxc/lang/translation/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux index 65bb5b772..c75ef0a19 100644 --- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/expression.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:] @@ -8,25 +8,25 @@ [macro] (macro ["s" syntax])) (luxc ["&" lang] - (lang [";L" variable #+ Variable Register] + (lang [".L" variable #+ Variable Register] (host ["$" jvm]) ["ls" synthesis] - (translation [";T" common] - [";T" primitive] - [";T" structure] - [";T" eval] - [";T" procedure] - [";T" function] - [";T" reference] - [";T" case])))) + (translation [".T" common] + [".T" primitive] + [".T" structure] + [".T" eval] + [".T" procedure] + [".T" function] + [".T" reference] + [".T" case])))) (exception: #export Unrecognized-Synthesis) (def: #export (translate synthesis) - (-> ls;Synthesis (Meta $;Inst)) + (-> ls.Synthesis (Meta $.Inst)) (case synthesis (^code []) - primitiveT;translate-unit + primitiveT.translate-unit (^code [(~ singleton)]) (translate singleton) @@ -34,43 +34,43 @@ (^template [<tag> <generator>] [_ (<tag> value)] (<generator> value)) - ([#;Bool primitiveT;translate-bool] - [#;Nat primitiveT;translate-nat] - [#;Int primitiveT;translate-int] - [#;Deg primitiveT;translate-deg] - [#;Frac primitiveT;translate-frac] - [#;Text primitiveT;translate-text]) + ([#.Bool primitiveT.translate-bool] + [#.Nat primitiveT.translate-nat] + [#.Int primitiveT.translate-int] + [#.Deg primitiveT.translate-deg] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) - (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS))) - (structureT;translate-variant translate tag last? valueS) + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (structureT.translate-variant translate tag last? valueS) (^code [(~@ members)]) - (structureT;translate-tuple translate members) + (structureT.translate-tuple translate members) - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (if (variableL;captured? var) - (referenceT;translate-captured var) - (referenceT;translate-local var)) + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (if (variableL.captured? var) + (referenceT.translate-captured var) + (referenceT.translate-local var)) - [_ (#;Symbol definition)] - (referenceT;translate-definition definition) + [_ (#.Symbol definition)] + (referenceT.translate-definition definition) - (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS))) - (caseT;translate-let translate register inputS exprS) + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (caseT.translate-let translate register inputS exprS) (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT;translate-case translate inputS pathPS) + (caseT.translate-case translate inputS pathPS) - (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS))) - [(s;run environment (p;some s;int)) (#e;Success environment)]) - (functionT;translate-function translate environment arity bodyS) + (^multi (^code ("lux function" (~ [_ (#.Nat arity)]) [(~@ environment)] (~ bodyS))) + [(s.run environment (p.some s.int)) (#e.Success environment)]) + (functionT.translate-function translate environment arity bodyS) (^code ("lux call" (~ functionS) (~@ argsS))) - (functionT;translate-call translate functionS argsS) + (functionT.translate-call translate functionS argsS) - (^code ((~ [_ (#;Text procedure)]) (~@ argsS))) - (procedureT;translate-procedure translate procedure argsS) + (^code ((~ [_ (#.Text procedure)]) (~@ argsS))) + (procedureT.translate-procedure translate procedure argsS) _ - (&;throw Unrecognized-Synthesis (%code synthesis)) + (&.throw Unrecognized-Synthesis (%code synthesis)) )) diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index ab3382952..3070800fe 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data [text] @@ -6,320 +6,320 @@ (coll [list "list/" Functor<List> Monoid<List>])) [macro]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common] - [";T" runtime] - [";T" reference]) - [";L" variable #+ Variable]))) + (translation [".T" common] + [".T" runtime] + [".T" reference]) + [".L" variable #+ Variable]))) (def: arity-field Text "arity") -(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: (poly-arg? arity) - (-> ls;Arity Bool) - (n.> +1 arity)) + (-> ls.Arity Bool) + (n/> +1 arity)) (def: (reset-method class) - (-> Text $;Method) - ($t;method (list) (#;Some ($t;class class (list))) (list))) + (-> Text $.Method) + ($t.method (list) (#.Some ($t.class class (list))) (list))) (def: (captured-args env) - (-> (List Variable) (List $;Type)) - (list;repeat (list;size env) $Object)) + (-> (List Variable) (List $.Type)) + (list.repeat (list.size env) $Object)) (def: (init-method env arity) - (-> (List Variable) ls;Arity $;Method) + (-> (List Variable) ls.Arity $.Method) (if (poly-arg? arity) - ($t;method (list;concat (list (captured-args env) - (list $t;int) - (list;repeat (n.dec arity) $Object))) - #;None + ($t.method (list.concat (list (captured-args env) + (list $t.int) + (list.repeat (n/dec arity) $Object))) + #.None (list)) - ($t;method (captured-args env) #;None (list)))) + ($t.method (captured-args env) #.None (list)))) (def: (implementation-method arity) - ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) (def: get-amount-of-partialsI - $;Inst - (|>. ($i;ALOAD +0) - ($i;GETFIELD hostL;function-class runtimeT;partials-field $t;int))) + $.Inst + (|>> ($i.ALOAD +0) + ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int))) (def: (load-fieldI class field) - (-> Text Text $;Inst) - (|>. ($i;ALOAD +0) - ($i;GETFIELD class field $Object))) + (-> Text Text $.Inst) + (|>> ($i.ALOAD +0) + ($i.GETFIELD class field $Object))) (def: (inputsI start amount) - (-> $;Register Nat $;Inst) - (|> (list;n.range start (n.+ start (n.dec amount))) - (list/map $i;ALOAD) - $i;fuse)) + (-> $.Register Nat $.Inst) + (|> (list.n/range start (n/+ start (n/dec amount))) + (list/map $i.ALOAD) + $i.fuse)) (def: (applysI start amount) - (-> $;Register Nat $;Inst) - (let [max-args (n.min amount runtimeT;num-apply-variants) - later-applysI (if (n.> runtimeT;num-apply-variants amount) - (applysI (n.+ runtimeT;num-apply-variants start) (n.- runtimeT;num-apply-variants amount)) + (-> $.Register Nat $.Inst) + (let [max-args (n/min amount runtimeT.num-apply-variants) + later-applysI (if (n/> runtimeT.num-apply-variants amount) + (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount)) id)] - (|>. ($i;CHECKCAST hostL;function-class) + (|>> ($i.CHECKCAST hostL.function-class) (inputsI start max-args) - ($i;INVOKEVIRTUAL hostL;function-class runtimeT;apply-method (runtimeT;apply-signature max-args) false) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false) later-applysI))) (def: (inc-intI by) - (-> Nat $;Inst) - (|>. ($i;int (nat-to-int by)) - $i;IADD)) + (-> Nat $.Inst) + (|>> ($i.int (nat-to-int by)) + $i.IADD)) (def: (nullsI amount) - (-> Nat $;Inst) - (|> $i;NULL - (list;repeat amount) - $i;fuse)) + (-> Nat $.Inst) + (|> $i.NULL + (list.repeat amount) + $i.fuse)) (def: (with-captured env) - (-> (List Variable) $;Def) - (|> (list;enumerate env) + (-> (List Variable) $.Def) + (|> (list.enumerate env) (list/map (function [[env-idx env-source]] - ($d;field #$;Private $;finalF (referenceT;captured env-idx) $Object))) - $d;fuse)) + ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object))) + $d.fuse)) (def: (with-partial arity) - (-> ls;Arity $;Def) + (-> ls.Arity $.Def) (if (poly-arg? arity) - (|> (list;n.range +0 (n.- +2 arity)) + (|> (list.n/range +0 (n/- +2 arity)) (list/map (function [idx] - ($d;field #$;Private $;finalF (referenceT;partial idx) $Object))) - $d;fuse) + ($d.field #$.Private $.finalF (referenceT.partial idx) $Object))) + $d.fuse) id)) (def: (instance class arity env) - (-> Text ls;Arity (List Variable) (Meta $;Inst)) - (do macro;Monad<Meta> - [captureI+ (monad;map @ referenceT;translate-variable env) + (-> Text ls.Arity (List Variable) (Meta $.Inst)) + (do macro.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) + (|> (nullsI (n/dec arity)) + (list ($i.int 0)) + $i.fuse) id)]] - (wrap (|>. ($i;NEW class) - $i;DUP - ($i;fuse captureI+) + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse captureI+) argsI - ($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))) + ($i.INVOKESPECIAL class "<init>" (init-method env arity) false))))) (def: (with-reset class arity env) - (-> Text ls;Arity (List Variable) $;Def) - ($d;method #$;Public $;noneM "reset" (reset-method class) + (-> Text ls.Arity (List Variable) $.Def) + ($d.method #$.Public $.noneM "reset" (reset-method class) (if (poly-arg? arity) - (let [env-size (list;size env) + (let [env-size (list.size env) captureI (|> (case env-size +0 (list) - _ (list;n.range +0 (n.dec env-size))) + _ (list.n/range +0 (n/dec env-size))) (list/map (function [source] - (|>. ($i;ALOAD +0) - ($i;GETFIELD class (referenceT;captured source) $Object)))) - $i;fuse) - argsI (|> (nullsI (n.dec arity)) - (list ($i;int 0)) - $i;fuse)] - (|>. ($i;NEW class) - $i;DUP + (|>> ($i.ALOAD +0) + ($i.GETFIELD class (referenceT.captured source) $Object)))) + $i.fuse) + argsI (|> (nullsI (n/dec arity)) + (list ($i.int 0)) + $i.fuse)] + (|>> ($i.NEW class) + $i.DUP captureI argsI - ($i;INVOKESPECIAL class "<init>" (init-method env arity) false) - $i;ARETURN)) - (|>. ($i;ALOAD +0) - $i;ARETURN)))) + ($i.INVOKESPECIAL class "<init>" (init-method env arity) false) + $i.ARETURN)) + (|>> ($i.ALOAD +0) + $i.ARETURN)))) (def: (with-implementation arity @begin bodyI) - (-> Nat $;Label $;Inst $;Def) - ($d;method #$;Public $;strictM "impl" (implementation-method arity) - (|>. ($i;label @begin) + (-> Nat $.Label $.Inst $.Def) + ($d.method #$.Public $.strictM "impl" (implementation-method arity) + (|>> ($i.label @begin) bodyI - $i;ARETURN))) + $i.ARETURN))) (def: function-init-method - $;Method - ($t;method (list $t;int) #;None (list))) + $.Method + ($t.method (list $t.int) #.None (list))) (def: (function-init arity env-size) - (-> ls;Arity Nat $;Inst) - (if (n.= +1 arity) - (|>. ($i;int 0) - ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false)) - (|>. ($i;ILOAD (n.inc env-size)) - ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false)))) + (-> ls.Arity Nat $.Inst) + (if (n/= +1 arity) + (|>> ($i.int 0) + ($i.INVOKESPECIAL hostL.function-class "<init>" function-init-method false)) + (|>> ($i.ILOAD (n/inc env-size)) + ($i.INVOKESPECIAL hostL.function-class "<init>" function-init-method false)))) (def: (with-init class env arity) - (-> Text (List Variable) ls;Arity $;Def) - (let [env-size (list;size env) + (-> Text (List Variable) ls.Arity $.Def) + (let [env-size (list.size env) offset-partial (: (-> Nat Nat) - (|>. n.inc (n.+ env-size))) + (|>> n/inc (n/+ env-size))) store-capturedI (|> (case env-size +0 (list) - _ (list;n.range +0 (n.dec env-size))) + _ (list.n/range +0 (n/dec env-size))) (list/map (function [register] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (referenceT;captured register) $Object)))) - $i;fuse) + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.captured register) $Object)))) + $i.fuse) store-partialI (if (poly-arg? arity) - (|> (list;n.range +0 (n.- +2 arity)) + (|> (list.n/range +0 (n/- +2 arity)) (list/map (function [idx] (let [register (offset-partial idx)] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (referenceT;partial idx) $Object))))) - $i;fuse) + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.partial idx) $Object))))) + $i.fuse) id)] - ($d;method #$;Public $;noneM "<init>" (init-method env arity) - (|>. ($i;ALOAD +0) + ($d.method #$.Public $.noneM "<init>" (init-method env arity) + (|>> ($i.ALOAD +0) (function-init arity env-size) store-capturedI store-partialI - $i;RETURN)))) + $i.RETURN)))) (def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity - $;Def) - (let [num-partials (n.dec function-arity) - @default ($;new-label []) - @labels (list/map $;new-label (list;repeat num-partials [])) - arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity))) + (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity + $.Def) + (let [num-partials (n/dec function-arity) + @default ($.new-label []) + @labels (list/map $.new-label (list.repeat num-partials [])) + arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-int apply-arity))) casesI (|> (list/compose @labels (list @default)) - (list;zip2 (list;n.range +0 num-partials)) + (list.zip2 (list.n/range +0 num-partials)) (list/map (function [[stage @label]] - (let [load-partialsI (if (n.> +0 stage) - (|> (list;n.range +0 (n.dec stage)) - (list/map (|>. referenceT;partial (load-fieldI class))) - $i;fuse) + (let [load-partialsI (if (n/> +0 stage) + (|> (list.n/range +0 (n/dec stage)) + (list/map (|>> referenceT.partial (load-fieldI class))) + $i.fuse) id)] - (cond (i.= arity-over-extent (nat-to-int stage)) - (|>. ($i;label @label) - ($i;ALOAD +0) - (when (n.> +0 stage) - ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)) + (cond (i/= arity-over-extent (nat-to-int stage)) + (|>> ($i.label @label) + ($i.ALOAD +0) + (when (n/> +0 stage) + ($i.INVOKEVIRTUAL class "reset" (reset-method class) false)) load-partialsI (inputsI +1 apply-arity) - ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - $i;ARETURN) + ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + $i.ARETURN) - (i.> arity-over-extent (nat-to-int stage)) - (let [args-to-completion (|> function-arity (n.- stage)) - args-left (|> apply-arity (n.- args-to-completion))] - (|>. ($i;label @label) - ($i;ALOAD +0) - ($i;INVOKEVIRTUAL class "reset" (reset-method class) false) + (i/> arity-over-extent (nat-to-int stage)) + (let [args-to-completion (|> function-arity (n/- stage)) + args-left (|> apply-arity (n/- args-to-completion))] + (|>> ($i.label @label) + ($i.ALOAD +0) + ($i.INVOKEVIRTUAL class "reset" (reset-method class) false) load-partialsI (inputsI +1 args-to-completion) - ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - (applysI (n.inc args-to-completion) args-left) - $i;ARETURN)) + ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + (applysI (n/inc args-to-completion) args-left) + $i.ARETURN)) - ## (i.< arity-over-extent (nat-to-int stage)) - (let [env-size (list;size env) + ## (i/< arity-over-extent (nat-to-int stage)) + (let [env-size (list.size env) load-capturedI (|> (case env-size +0 (list) - _ (list;n.range +0 (n.dec env-size))) - (list/map (|>. referenceT;captured (load-fieldI class))) - $i;fuse)] - (|>. ($i;label @label) - ($i;NEW class) - $i;DUP + _ (list.n/range +0 (n/dec env-size))) + (list/map (|>> referenceT.captured (load-fieldI class))) + $i.fuse)] + (|>> ($i.label @label) + ($i.NEW class) + $i.DUP load-capturedI get-amount-of-partialsI (inc-intI apply-arity) load-partialsI (inputsI +1 apply-arity) - (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) - ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false) - $i;ARETURN)) + (nullsI (|> num-partials (n/- apply-arity) (n/- stage))) + ($i.INVOKESPECIAL class "<init>" (init-method env function-arity) false) + $i.ARETURN)) )))) - $i;fuse)] - ($d;method #$;Public $;noneM runtimeT;apply-method (runtimeT;apply-signature apply-arity) - (|>. get-amount-of-partialsI - ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) + $i.fuse)] + ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity) + (|>> get-amount-of-partialsI + ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int) @default @labels) casesI - ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) - $i;NULL - $i;ARETURN + ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false) + $i.NULL + $i.ARETURN )))) (def: #export (with-function @begin class env arity bodyI) - (-> $;Label Text (List Variable) ls;Arity $;Inst - (Meta [$;Def $;Inst])) - (let [env-size (list;size env) - applyD (: $;Def + (-> $.Label Text (List Variable) ls.Arity $.Inst + (Meta [$.Def $.Inst])) + (let [env-size (list.size env) + applyD (: $.Def (if (poly-arg? arity) - (|> (n.min arity runtimeT;num-apply-variants) - (list;n.range +1) + (|> (n/min arity runtimeT.num-apply-variants) + (list.n/range +1) (list/map (with-apply class env arity @begin bodyI)) (list& (with-implementation arity @begin bodyI)) - $d;fuse) - ($d;method #$;Public $;strictM runtimeT;apply-method (runtimeT;apply-signature +1) - (|>. ($i;label @begin) + $d.fuse) + ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1) + (|>> ($i.label @begin) bodyI - $i;ARETURN)))) - functionD (: $;Def - (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity)) + $i.ARETURN)))) + functionD (: $.Def + (|>> ($d.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (nat-to-int arity)) (with-captured env) (with-partial arity) (with-init class env arity) (with-reset class arity env) applyD ))] - (do macro;Monad<Meta> + (do macro.Monad<Meta> [instanceI (instance class arity env)] (wrap [functionD instanceI])))) (def: #export (translate-function translate env arity bodyS) - (-> (-> ls;Synthesis (Meta $;Inst)) - (List Variable) ls;Arity ls;Synthesis - (Meta $;Inst)) - (do macro;Monad<Meta> - [@begin $i;make-label - [function-class bodyI] (hostL;with-sub-context - (hostL;with-anchor [@begin +1] + (-> (-> ls.Synthesis (Meta $.Inst)) + (List Variable) ls.Arity ls.Synthesis + (Meta $.Inst)) + (do macro.Monad<Meta> + [@begin $i.make-label + [function-class bodyI] (hostL.with-sub-context + (hostL.with-anchor [@begin +1] (translate bodyS))) - this-module macro;current-module-name - #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)] + this-module macro.current-module-name + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)] [functionD instanceI] (with-function @begin function-class env arity bodyI) - _ (commonT;store-class function-class - ($d;class #$;V1.6 #$;Public $;finalC + _ (commonT.store-class function-class + ($d.class #$.V1_6 #$.Public $.finalC function-class (list) - ($;simple-class hostL;function-class) (list) + ($.simple-class hostL.function-class) (list) functionD))] (wrap instanceI))) (def: (segment size elems) (All [a] (-> Nat (List a) (List (List a)))) - (let [[pre post] (list;split size elems)] - (if (list;empty? post) + (let [[pre post] (list.split size elems)] + (if (list.empty? post) (list pre) (list& pre (segment size post))))) (def: #export (translate-call translate functionS argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Synthesis (List ls;Synthesis) - (Meta $;Inst)) - (do macro;Monad<Meta> + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad<Meta> [functionI (translate functionS) - argsI (monad;map @ translate argsS) - #let [applyI (|> (segment runtimeT;num-apply-variants argsI) + argsI (monad.map @ translate argsS) + #let [applyI (|> (segment runtimeT.num-apply-variants argsI) (list/map (function [chunkI+] - (|>. ($i;CHECKCAST hostL;function-class) - ($i;fuse chunkI+) - ($i;INVOKEVIRTUAL hostL;function-class runtimeT;apply-method (runtimeT;apply-signature (list;size chunkI+)) false)))) - $i;fuse)]] - (wrap (|>. functionI + (|>> ($i.CHECKCAST hostL.function-class) + ($i.fuse chunkI+) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false)))) + $i.fuse)]] + (wrap (|>> functionI applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux index be8b828cd..892dd869f 100644 --- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser] @@ -19,16 +19,16 @@ [io #+ IO Process io] [host]) (luxc ["&" lang] - (lang [";L" module]))) + (lang [".L" module]))) (exception: #export Invalid-Imports) (exception: #export Module-Cannot-Import-Itself) (exception: #export Circular-Dependency) -(host;import (java.util.concurrent.Future a) +(host.import (java/util/concurrent/Future a) (get [] #io a)) -(host;import (java.util.concurrent.CompletableFuture a) +(host.import (java/util/concurrent/CompletableFuture a) (new []) (complete [a] boolean) (#static [a] completedFuture [a] (CompletableFuture a))) @@ -37,55 +37,55 @@ {#module Text #alias Text}) -(def: import (s;Syntax Import) (s;tuple (p;seq s;text s;text))) +(def: import (s.Syntax Import) (s.tuple (p.seq s.text s.text))) (def: compilations (Var (Dict Text (CompletableFuture (Error Compiler)))) - (stm;var (dict;new text;Hash<Text>))) + (stm.var (dict.new text.Hash<Text>))) (def: (promise-to-future promise) (All [a] (-> (Promise a) (Future a))) - (let [future (CompletableFuture.new [])] - (exec (:: promise;Functor<Promise> map - (function [value] (CompletableFuture.complete [value] future)) + (let [future (CompletableFuture::new [])] + (exec (:: promise.Functor<Promise> map + (function [value] (CompletableFuture::complete [value] future)) promise) future))) (def: from-io (All [a] (-> (IO a) (Process a))) - (:: io;Monad<IO> map (|>. #e;Success))) + (:: io.Monad<IO> map (|>> #e.Success))) (def: (translate-dependency translate-module dependency compiler) (-> (-> Text Compiler (Process Compiler)) (-> Text Compiler (IO (Future (Error Compiler))))) - (<| (Future.get []) + (<| (Future::get []) promise-to-future - (do promise;Monad<Promise> - [[new? future] (stm;commit (: (STM [Bool (CompletableFuture (Error Compiler))]) - (do stm;Monad<STM> - [current-compilations (stm;read compilations)] - (case (dict;get dependency current-compilations) - (#;Some ongoing) + (do promise.Monad<Promise> + [[new? future] (stm.commit (: (STM [Bool (CompletableFuture (Error Compiler))]) + (do stm.Monad<STM> + [current-compilations (stm.read compilations)] + (case (dict.get dependency current-compilations) + (#.Some ongoing) (wrap [false ongoing]) - #;None + #.None (do @ [#let [pending (: (CompletableFuture (Error Compiler)) - (CompletableFuture.new []))] - _ (stm;write (dict;put dependency pending current-compilations) + (CompletableFuture::new []))] + _ (stm.write (dict.put dependency pending current-compilations) compilations)] (wrap [true pending]))))))] (if new? - (exec (promise;future (io (CompletableFuture.complete [(io;run (translate-module dependency compiler))] - future))) + (exec (promise.future (io (CompletableFuture::complete [(io.run (translate-module dependency compiler))] + future))) (wrap future)) (wrap future))))) (def: compiled? (-> Module Bool) - (|>. (get@ #;module-state) + (|>> (get@ #.module-state) (case> - (^or #;Cached #;Compiled) + (^or #.Cached #.Compiled) true _ @@ -94,56 +94,56 @@ (def: (merge-modules current-module from-dependency from-current) (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module])) (|> from-dependency - (list;filter (|>. product;right compiled?)) - (list/fold (function [[dep-name dep-module] total] (&;pl-put dep-name dep-module total)) + (list.filter (|>> product.right compiled?)) + (list/fold (function [[dep-name dep-module] total] (&.pl-put dep-name dep-module total)) from-current))) (def: (merge-compilers current-module dependency total) (-> Text Compiler Compiler Compiler) (|> total - (update@ #;modules (merge-modules current-module (get@ #;modules dependency))) - (set@ #;seed (get@ #;seed dependency)))) + (update@ #.modules (merge-modules current-module (get@ #.modules dependency))) + (set@ #.seed (get@ #.seed dependency)))) (def: #export (translate-imports translate-module annotations) (-> (-> Text Compiler (Process Compiler)) Code (Meta (Process Compiler))) - (do macro;Monad<Meta> - [_ (moduleL;set-annotations annotations) - current-module macro;current-module-name - imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations) - (maybe;default (list)))] - (case (s;run imports (p;some import)) - (#e;Success imports) + (do macro.Monad<Meta> + [_ (moduleL.set-annotations annotations) + current-module macro.current-module-name + imports (let [imports (|> (macro.get-tuple-ann (ident-for #.imports) annotations) + (maybe.default (list)))] + (case (s.run imports (p.some import)) + (#e.Success imports) (wrap imports) - (#e;Error error) - (&;throw Invalid-Imports (%code (code;tuple imports))))) - dependencies (monad;map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler))))) + (#e.Error error) + (&.throw Invalid-Imports (%code (code.tuple imports))))) + dependencies (monad.map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler))))) (function [[dependency alias]] (do @ - [_ (&;assert Module-Cannot-Import-Itself current-module + [_ (&.assert Module-Cannot-Import-Itself current-module (not (text/= current-module dependency))) - already-seen? (moduleL;exists? dependency) + already-seen? (moduleL.exists? dependency) circular-dependency? (if already-seen? - (moduleL;active? dependency) + (moduleL.active? dependency) (wrap false)) - _ (&;assert Circular-Dependency (format "From: " current-module "\n" + _ (&.assert Circular-Dependency (format "From: " current-module "\n" " To: " dependency) (not circular-dependency?)) - _ (moduleL;import dependency) + _ (moduleL.import dependency) _ (if (text/= "" alias) (wrap []) - (moduleL;alias alias dependency)) - compiler macro;get-compiler] + (moduleL.alias alias dependency)) + compiler macro.get-compiler] (if already-seen? - (wrap (io (CompletableFuture.completedFuture [(#e;Success compiler)]))) + (wrap (io (CompletableFuture::completedFuture [(#e.Success compiler)]))) (wrap (translate-dependency translate-module dependency compiler)))))) imports) - compiler macro;get-compiler] - (wrap (do io;Monad<Process> - [dependencies (monad;seq io;Monad<Process> (list/map from-io dependencies)) + compiler macro.get-compiler] + (wrap (do io.Monad<Process> + [dependencies (monad.seq io.Monad<Process> (list/map from-io dependencies)) dependencies (|> dependencies - (list/map (Future.get [])) - (monad;seq io;Monad<Process>))] + (list/map (Future::get [])) + (monad.seq io.Monad<Process>))] (wrap (list/fold (merge-compilers current-module) compiler dependencies)))))) diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux index 77d43a0e5..8920dc936 100644 --- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data [text] @@ -6,23 +6,23 @@ (coll [list "list/" Functor<List> Monoid<List>])) [macro]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common] - [";T" runtime] - [";T" reference]) - [";L" variable #+ Variable Register]))) + (translation [".T" common] + [".T" runtime] + [".T" reference]) + [".L" variable #+ Variable Register]))) (def: (constant? register changeS) - (-> Register ls;Synthesis Bool) + (-> Register ls.Synthesis Bool) (case changeS - (^multi (^code ((~ [_ (#;Int var)]))) - (i.= (variableL;local register) + (^multi (^code ((~ [_ (#.Int var)]))) + (i/= (variableL.local register) var)) true @@ -30,12 +30,12 @@ false)) (def: #export (translate-recur translate argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) - (List ls;Synthesis) - (Meta $;Inst)) - (do macro;Monad<Meta> - [[@begin offset] hostL;anchor - #let [pairs (list;zip2 (list;n.range offset (|> (list;size argsS) n.dec (n.+ offset))) + (-> (-> ls.Synthesis (Meta $.Inst)) + (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad<Meta> + [[@begin offset] hostL.anchor + #let [pairs (list.zip2 (list.n/range offset (|> (list.size argsS) n/dec (n/+ offset))) argsS)] ## It may look weird that first I compile the values separately, ## and then I compile the stores/allocations. @@ -45,36 +45,36 @@ ## and stores separately, then by the time Y is evaluated, it ## will refer to the new value of X, instead of the old value, as ## must be the case. - valuesI+ (monad;map @ (function [[register argS]] - (: (Meta $;Inst) + valuesI+ (monad.map @ (function [[register argS]] + (: (Meta $.Inst) (if (constant? register argS) (wrap id) (translate argS)))) pairs) #let [storesI+ (list/map (function [[register argS]] - (: $;Inst + (: $.Inst (if (constant? register argS) id - ($i;ASTORE register)))) - (list;reverse pairs))]] - (wrap (|>. ($i;fuse valuesI+) - ($i;fuse storesI+) - ($i;GOTO @begin))))) + ($i.ASTORE register)))) + (list.reverse pairs))]] + (wrap (|>> ($i.fuse valuesI+) + ($i.fuse storesI+) + ($i.GOTO @begin))))) (def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat (List ls;Synthesis) ls;Synthesis - (Meta $;Inst)) - (do macro;Monad<Meta> - [@begin $i;make-label - initsI+ (monad;map @ translate initsS+) - bodyI (hostL;with-anchor [@begin offset] + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat (List ls.Synthesis) ls.Synthesis + (Meta $.Inst)) + (do macro.Monad<Meta> + [@begin $i.make-label + initsI+ (monad.map @ translate initsS+) + bodyI (hostL.with-anchor [@begin offset] (translate bodyS)) - #let [initializationI (|> (list;enumerate initsI+) + #let [initializationI (|> (list.enumerate initsI+) (list/map (function [[register initI]] - (|>. initI - ($i;ASTORE (n.+ offset register))))) - $i;fuse)]] - (wrap (|>. initializationI - ($i;label @begin) + (|>> initI + ($i.ASTORE (n/+ offset register))))) + $i.fuse)]] + (wrap (|>> initializationI + ($i.label @begin) bodyI)))) diff --git a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux index acd3b95e3..8fed1de18 100644 --- a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux @@ -1,35 +1,35 @@ -(;module: +(.module: lux (lux (control monad) (data text/format) [macro "macro/" Monad<Meta>]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$i" inst] ["$t" type])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])))) + (translation [".T" common])))) (def: #export translate-unit - (Meta $;Inst) - (macro/wrap ($i;string hostL;unit))) + (Meta $.Inst) + (macro/wrap ($i.string hostL.unit))) (def: #export (translate-bool value) - (-> Bool (Meta $;Inst)) - (macro/wrap ($i;GETSTATIC "java.lang.Boolean" + (-> Bool (Meta $.Inst)) + (macro/wrap ($i.GETSTATIC "java.lang.Boolean" (if value "TRUE" "FALSE") - ($t;class "java.lang.Boolean" (list))))) + ($t.class "java.lang.Boolean" (list))))) (do-template [<name> <type> <load> <wrap>] [(def: #export (<name> value) - (-> <type> (Meta $;Inst)) - (macro/wrap (|>. (<load> value) <wrap>)))] + (-> <type> (Meta $.Inst)) + (macro/wrap (|>> (<load> value) <wrap>)))] - [translate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [translate-int Int $i;long ($i;wrap #$;Long)] - [translate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [translate-frac Frac $i;double ($i;wrap #$;Double)] - [translate-text Text $i;string id] + [translate-nat Nat (|>> (:! Int) $i.long) ($i.wrap #$.Long)] + [translate-int Int $i.long ($i.wrap #$.Long)] + [translate-deg Deg (|>> (:! Int) $i.long) ($i.wrap #$.Long)] + [translate-frac Frac $i.double ($i.wrap #$.Double)] + [translate-text Text $i.string id] ) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux index 14fbe2f1a..e4f8b9908 100644 --- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -8,20 +8,20 @@ (luxc ["&" lang] (lang (host ["$" jvm]) ["ls" synthesis])) - (/ ["/;" common] - ["/;" host])) + (/ ["/." common] + ["/." host])) (exception: #export Unknown-Procedure) (def: procedures - /common;Bundle - (|> /common;procedures - (dict;merge /host;procedures))) + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) (def: #export (translate-procedure translate name args) - (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis) - (Meta $;Inst)) - (<| (maybe;default (&;throw Unknown-Procedure (%t name))) - (do maybe;Monad<Maybe> - [proc (dict;get name procedures)] + (-> (-> ls.Synthesis (Meta $.Inst)) Text (List ls.Synthesis) + (Meta $.Inst)) + (<| (maybe.default (&.throw Unknown-Procedure (%t name))) + (do maybe.Monad<Maybe> + [proc (dict.get name procedures)] (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 01f2a33c7..41d9b91ab 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser] @@ -13,23 +13,23 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" runtime] - [";T" case] - [";T" function] - [";T" loop])))) + (translation [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])))) -(host;import java.lang.Long +(host.import java/lang/Long (#static MIN_VALUE Long) (#static MAX_VALUE Long)) -(host;import java.lang.Double +(host.import java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE Double) (#static NaN Double) @@ -38,42 +38,42 @@ ## [Types] (type: #export Translator - (-> ls;Synthesis (Meta $;Inst))) + (-> ls.Synthesis (Meta $.Inst))) (type: #export Proc - (-> Translator (List ls;Synthesis) (Meta $;Inst))) + (-> Translator (List ls.Synthesis) (Meta $.Inst))) (type: #export Bundle (Dict Text Proc)) -(syntax: (Vector [size s;nat] elemT) - (wrap (list (` [(~@ (list;repeat size elemT))])))) +(syntax: (Vector [size s.nat] elemT) + (wrap (list (` [(~@ (list.repeat size elemT))])))) -(type: #export Nullary (-> (Vector +0 $;Inst) $;Inst)) -(type: #export Unary (-> (Vector +1 $;Inst) $;Inst)) -(type: #export Binary (-> (Vector +2 $;Inst) $;Inst)) -(type: #export Trinary (-> (Vector +3 $;Inst) $;Inst)) -(type: #export Variadic (-> (List $;Inst) $;Inst)) +(type: #export Nullary (-> (Vector +0 $.Inst) $.Inst)) +(type: #export Unary (-> (Vector +1 $.Inst) $.Inst)) +(type: #export Binary (-> (Vector +2 $.Inst) $.Inst)) +(type: #export Trinary (-> (Vector +3 $.Inst) $.Inst)) +(type: #export Variadic (-> (List $.Inst) $.Inst)) ## [Utils] -(def: $Object $;Type ($t;class "java.lang.Object" (list))) -(def: $Object-Array $;Type ($t;array +1 $Object)) -(def: $Variant $;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 hostL;function-class (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array +1 $Object)) +(def: $Variant $.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 hostL.function-class (list))) (def: #export (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (dict;put name (unnamed name))) + (dict.put name (unnamed name))) (def: #export (prefix prefix bundle) (-> Text Bundle Bundle) (|> bundle - dict;entries + dict.entries (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: (wrong-arity proc expected actual) (-> Text Nat Nat Text) @@ -81,26 +81,26 @@ "Expected: " (|> expected nat-to-int %i) "\n" " Actual: " (|> actual nat-to-int %i))) -(syntax: (arity: [name s;local-symbol] [arity s;nat]) +(syntax: (arity: [name s.local-symbol] [arity s.nat]) (with-gensyms [g!proc g!name g!translate g!inputs] (do @ - [g!input+ (monad;seq @ (list;repeat arity (macro;gensym "input")))] - (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc)) - (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst) - (-> Text ;;Proc)) + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst) + (-> Text ..Proc)) (function [(~ g!name)] (function [(~ g!translate) (~ g!inputs)] (case (~ g!inputs) (^ (list (~@ g!input+))) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [(~@ (|> g!input+ (list/map (function [g!input] (list g!input (` ((~ g!translate) (~ g!input)))))) - list;concat))] + list.concat))] ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) (~' _) - (macro;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs)))))))))))))) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) (arity: nullary +0) (arity: unary +1) @@ -111,54 +111,54 @@ (-> Variadic (-> Text Proc)) (function [proc-name] (function [translate inputsS] - (do macro;Monad<Meta> - [inputsI (monad;map @ translate inputsS)] + (do macro.Monad<Meta> + [inputsI (monad.map @ translate inputsS)] (wrap (proc inputsI)))))) ## [Instructions] -(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long))) -(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I)) +(def: lux-intI $.Inst (|>> $i.I2L ($i.wrap #$.Long))) +(def: jvm-intI $.Inst (|>> ($i.unwrap #$.Long) $i.L2I)) (def: (array-writeI arrayI idxI elemI) - (-> $;Inst $;Inst $;Inst - $;Inst) - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - $i;DUP + (-> $.Inst $.Inst $.Inst + $.Inst) + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) + $i.DUP idxI jvm-intI elemI - $i;AASTORE)) + $i.AASTORE)) (def: (predicateI tester) - (-> (-> $;Label $;Inst) - $;Inst) - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. (tester @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end) + (-> (-> $.Label $.Inst) + $.Inst) + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> (tester @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end) ))) ## [Procedures] ## [[Lux]] (def: (lux//is [leftI rightI]) Binary - (|>. leftI + (|>> leftI rightI - (predicateI $i;IF_ACMPEQ))) + (predicateI $i.IF_ACMPEQ))) (def: (lux//if [testI thenI elseI]) Trinary - (caseT;translate-if testI thenI elseI)) + (caseT.translate-if testI thenI elseI)) (def: (lux//try riskyI) Unary - (|>. riskyI - ($i;CHECKCAST hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "try" - ($t;method (list $Function) (#;Some $Object-Array) (list)) + (|>> riskyI + ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "try" + ($t.method (list $Function) (#.Some $Object-Array) (list)) false))) (def: (lux//noop valueI) @@ -167,80 +167,80 @@ (exception: #export Wrong-Syntax) (def: #export (wrong-syntax procedure args) - (-> Text (List ls;Synthesis) Text) + (-> Text (List ls.Synthesis) Text) (format "Procedure: " procedure "\n" - "Arguments: " (%code (code;tuple args)))) + "Arguments: " (%code (code.tuple args)))) (def: lux//loop (-> Text Proc) (function [proc-name] (function [translate inputsS] - (case (s;run inputsS ($_ p;seq s;nat (s;tuple (p;many s;any)) s;any)) - (#e;Success [offset initsS+ bodyS]) - (loopT;translate-loop translate offset initsS+ bodyS) + (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) + (#e.Success [offset initsS+ bodyS]) + (loopT.translate-loop translate offset initsS+ bodyS) - (#e;Error error) - (&;throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + (#e.Error error) + (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) ))) (def: lux//recur (-> Text Proc) (function [proc-name] (function [translate inputsS] - (loopT;translate-recur translate inputsS)))) + (loopT.translate-recur translate inputsS)))) ## [[Bits]] (do-template [<name> <op>] [(def: (<name> [inputI maskI]) Binary - (|>. inputI ($i;unwrap #$;Long) - maskI ($i;unwrap #$;Long) - <op> ($i;wrap #$;Long)))] + (|>> inputI ($i.unwrap #$.Long) + maskI ($i.unwrap #$.Long) + <op> ($i.wrap #$.Long)))] - [bit//and $i;LAND] - [bit//or $i;LOR] - [bit//xor $i;LXOR] + [bit//and $i.LAND] + [bit//or $i.LOR] + [bit//xor $i.LXOR] ) (def: (bit//count inputI) Unary - (|>. inputI ($i;unwrap #$;Long) - ($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false) + (|>> inputI ($i.unwrap #$.Long) + ($i.INVOKESTATIC "java.lang.Long" "bitCount" ($t.method (list $t.long) (#.Some $t.int) (list)) false) lux-intI)) (do-template [<name> <op>] [(def: (<name> [inputI shiftI]) Binary - (|>. inputI ($i;unwrap #$;Long) + (|>> inputI ($i.unwrap #$.Long) shiftI jvm-intI <op> - ($i;wrap #$;Long)))] + ($i.wrap #$.Long)))] - [bit//shift-left $i;LSHL] - [bit//shift-right $i;LSHR] - [bit//unsigned-shift-right $i;LUSHR] + [bit//shift-left $i.LSHL] + [bit//shift-right $i.LSHR] + [bit//unsigned-shift-right $i.LUSHR] ) ## [[Arrays]] (def: (array//new lengthI) Unary - (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;binary-name "java.lang.Object")))) + (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) (def: (array//get [arrayI idxI]) Binary - (<| $i;with-label (function [@is-null]) - $i;with-label (function [@end]) - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + (<| $i.with-label (function [@is-null]) + $i.with-label (function [@end]) + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) idxI jvm-intI - $i;AALOAD - $i;DUP - ($i;IFNULL @is-null) - runtimeT;someI - ($i;GOTO @end) - ($i;label @is-null) - $i;POP - runtimeT;noneI - ($i;label @end)))) + $i.AALOAD + $i.DUP + ($i.IFNULL @is-null) + runtimeT.someI + ($i.GOTO @end) + ($i.label @is-null) + $i.POP + runtimeT.noneI + ($i.label @end)))) (def: (array//put [arrayI idxI elemI]) Trinary @@ -248,137 +248,137 @@ (def: (array//remove [arrayI idxI]) Binary - (array-writeI arrayI idxI $i;NULL)) + (array-writeI arrayI idxI $i.NULL)) (def: (array//size arrayI) Unary - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - $i;ARRAYLENGTH + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) + $i.ARRAYLENGTH lux-intI)) ## [[Numbers]] (def: nat-method - $;Method - ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) + $.Method + ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) -(def: deg-method $;Method nat-method) +(def: deg-method $.Method nat-method) (def: compare-nat-method - $;Method - ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) + $.Method + ($t.method (list $t.long $t.long) (#.Some $t.int) (list))) (do-template [<name> <const> <type>] [(def: (<name> _) Nullary - (|>. <const> ($i;wrap <type>)))] + (|>> <const> ($i.wrap <type>)))] - [nat//min ($i;long 0) #$;Long] - [nat//max ($i;long -1) #$;Long] + [nat//min ($i.long 0) #$.Long] + [nat//max ($i.long -1) #$.Long] - [int//min ($i;long Long.MIN_VALUE) #$;Long] - [int//max ($i;long Long.MAX_VALUE) #$;Long] + [int//min ($i.long Long::MIN_VALUE) #$.Long] + [int//max ($i.long Long::MAX_VALUE) #$.Long] - [frac//smallest ($i;double Double.MIN_VALUE) #$;Double] - [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) #$;Double] - [frac//max ($i;double Double.MAX_VALUE) #$;Double] - [frac//not-a-number ($i;double Double.NaN) #$;Double] - [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) #$;Double] - [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) #$;Double] - - [deg//min ($i;long 0) #$;Long] - [deg//max ($i;long -1) #$;Long] + [frac//smallest ($i.double Double::MIN_VALUE) #$.Double] + [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] + [frac//max ($i.double Double::MAX_VALUE) #$.Double] + [frac//not-a-number ($i.double Double::NaN) #$.Double] + [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] + [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] + + [deg//min ($i.long 0) #$.Long] + [deg//max ($i.long -1) #$.Long] ) (do-template [<name> <type> <op>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI ($i;unwrap <type>) - paramI ($i;unwrap <type>) + (|>> subjectI ($i.unwrap <type>) + paramI ($i.unwrap <type>) <op> - ($i;wrap <type>)))] + ($i.wrap <type>)))] - [int//add #$;Long $i;LADD] - [int//sub #$;Long $i;LSUB] - [int//mul #$;Long $i;LMUL] - [int//div #$;Long $i;LDIV] - [int//rem #$;Long $i;LREM] + [int//add #$.Long $i.LADD] + [int//sub #$.Long $i.LSUB] + [int//mul #$.Long $i.LMUL] + [int//div #$.Long $i.LDIV] + [int//rem #$.Long $i.LREM] - [nat//add #$;Long $i;LADD] - [nat//sub #$;Long $i;LSUB] - [nat//mul #$;Long $i;LMUL] - [nat//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] - [nat//rem #$;Long ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] - - [frac//add #$;Double $i;DADD] - [frac//sub #$;Double $i;DSUB] - [frac//mul #$;Double $i;DMUL] - [frac//div #$;Double $i;DDIV] - [frac//rem #$;Double $i;DREM] - - [deg//add #$;Long $i;LADD] - [deg//sub #$;Long $i;LSUB] - [deg//mul #$;Long ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] - [deg//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] - [deg//rem #$;Long $i;LSUB] - [deg//scale #$;Long $i;LMUL] - [deg//reciprocal #$;Long $i;LDIV] + [nat//add #$.Long $i.LADD] + [nat//sub #$.Long $i.LSUB] + [nat//mul #$.Long $i.LMUL] + [nat//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_nat" nat-method false)] + [nat//rem #$.Long ($i.INVOKESTATIC hostL.runtime-class "rem_nat" nat-method false)] + + [frac//add #$.Double $i.DADD] + [frac//sub #$.Double $i.DSUB] + [frac//mul #$.Double $i.DMUL] + [frac//div #$.Double $i.DDIV] + [frac//rem #$.Double $i.DREM] + + [deg//add #$.Long $i.LADD] + [deg//sub #$.Long $i.LSUB] + [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)] + [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)] + [deg//rem #$.Long $i.LSUB] + [deg//scale #$.Long $i.LMUL] + [deg//reciprocal #$.Long $i.LDIV] ) (do-template [<eq> <lt> <unwrap> <cmp>] [(do-template [<name> <reference>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI <unwrap> + (|>> subjectI <unwrap> paramI <unwrap> <cmp> - ($i;int <reference>) - (predicateI $i;IF_ICMPEQ)))] + ($i.int <reference>) + (predicateI $i.IF_ICMPEQ)))] [<eq> 0] [<lt> -1])] - [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 hostL;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 hostL.runtime-class "compare_nat" compare-nat-method false)] ) (do-template [<name> <prepare> <transform>] [(def: (<name> inputI) Unary - (|>. inputI <prepare> <transform>))] + (|>> inputI <prepare> <transform>))] [nat//to-int id id] - [nat//char ($i;unwrap #$;Long) - ((|>. $i;L2I $i;I2C ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false)))] + [nat//char ($i.unwrap #$.Long) + ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] [int//to-nat id id] - [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)] - - [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] - [frac//to-deg ($i;unwrap #$;Double) - (<| ($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 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 hostL;runtime-class "deg_to_frac" - ($t;method (list $t;long) (#;Some $t;double) (list)) false))] + [int//to-frac ($i.unwrap #$.Long) (<| ($i.wrap #$.Double) $i.L2D)] + + [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)] + [frac//to-deg ($i.unwrap #$.Double) + (<| ($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 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 hostL.runtime-class "deg_to_frac" + ($t.method (list $t.long) (#.Some $t.double) (list)) false))] ) ## [[Text]] (do-template [<name> <class> <method> <post> <outputT>] [(def: (<name> inputI) Unary - (|>. inputI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false) + (|>> inputI + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL <class> <method> ($t.method (list) (#.Some <outputT>) (list)) false) <post>))] - [text//size "java.lang.String" "length" lux-intI $t;int] - [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] + [text//size "java.lang.String" "length" lux-intI $t.int] + [text//hash "java.lang.Object" "hashCode" lux-intI $t.int] [text//trim "java.lang.String" "trim" id $String] [text//upper "java.lang.String" "toUpperCase" id $String] [text//lower "java.lang.String" "toLowerCase" id $String] @@ -387,86 +387,86 @@ (do-template [<name> <pre-subject> <pre-param> <op> <post>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI <pre-subject> + (|>> subjectI <pre-subject> paramI <pre-param> <op> <post>))] [text//eq id id - ($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false) - ($i;wrap #$;Boolean)] - [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false) - (<| (predicateI $i;IF_ICMPEQ) ($i;int -1))] - [text//concat ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) + ($i.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) false) + ($i.wrap #$.Boolean)] + [text//lt ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) false) + (<| (predicateI $i.IF_ICMPEQ) ($i.int -1))] + [text//concat ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false) id] - [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($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 hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $Variant) (list)) false) + [text//contains? ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") + ($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 hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) false) id] ) (do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>] [(def: (<name> [subjectI paramI extraI]) Trinary - (|>. subjectI <pre-subject> + (|>> subjectI <pre-subject> paramI <pre-param> extraI <pre-extra> <op>))] - [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i;INVOKESTATIC hostL;runtime-class "text_clip" - ($t;method (list $String $t;int $t;int) (#;Some $Variant) (list)) false)] - [text//replace-once ($i;CHECKCAST "java.lang.String") - (<| ($i;INVOKESTATIC "java.util.regex.Pattern" "quote" ($t;method (list $String) (#;Some $String) (list)) false) - ($i;CHECKCAST "java.lang.String")) - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t;method (list $String $String) (#;Some $String) (list)) false)] - [text//replace-all ($i;CHECKCAST "java.lang.String") - (<| ($i;INVOKESTATIC "java.util.regex.Pattern" "quote" ($t;method (list $String) (#;Some $String) (list)) false) - ($i;CHECKCAST "java.lang.String")) - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t;method (list $String $String) (#;Some $String) (list)) false)] + [text//clip ($i.CHECKCAST "java.lang.String") jvm-intI jvm-intI + ($i.INVOKESTATIC hostL.runtime-class "text_clip" + ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) false)] + [text//replace-once ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)] + [text//replace-all ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)] ) -(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list))) +(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) (do-template [<name> <method>] [(def: (<name> [textI partI startI]) Trinary - (<| $i;with-label (function [@not-found]) - $i;with-label (function [@end]) - (|>. textI ($i;CHECKCAST "java.lang.String") - partI ($i;CHECKCAST "java.lang.String") + (<| $i.with-label (function [@not-found]) + $i.with-label (function [@end]) + (|>> textI ($i.CHECKCAST "java.lang.String") + partI ($i.CHECKCAST "java.lang.String") startI jvm-intI - ($i;INVOKEVIRTUAL "java.lang.String" <method> index-method false) - $i;DUP - ($i;int -1) - ($i;IF_ICMPEQ @not-found) + ($i.INVOKEVIRTUAL "java.lang.String" <method> index-method false) + $i.DUP + ($i.int -1) + ($i.IF_ICMPEQ @not-found) lux-intI - runtimeT;someI - ($i;GOTO @end) - ($i;label @not-found) - $i;POP - runtimeT;noneI - ($i;label @end))))] + runtimeT.someI + ($i.GOTO @end) + ($i.label @not-found) + $i.POP + runtimeT.noneI + ($i.label @end))))] [text//index "indexOf"] [text//last-index "lastIndexOf"] ) ## [[Math]] -(def: math-unary-method ($t;method (list $t;double) (#;Some $t;double) (list))) -(def: math-binary-method ($t;method (list $t;double $t;double) (#;Some $t;double) (list))) +(def: math-unary-method ($t.method (list $t.double) (#.Some $t.double) (list))) +(def: math-binary-method ($t.method (list $t.double $t.double) (#.Some $t.double) (list))) (do-template [<name> <method>] [(def: (<name> inputI) Unary - (|>. inputI - ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Math" <method> math-unary-method false) - ($i;wrap #$;Double)))] + (|>> inputI + ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" <method> math-unary-method false) + ($i.wrap #$.Double)))] [math//cos "cos"] [math//sin "sin"] @@ -488,10 +488,10 @@ (do-template [<name> <method>] [(def: (<name> [inputI paramI]) Binary - (|>. inputI ($i;unwrap #$;Double) - paramI ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Math" <method> math-binary-method false) - ($i;wrap #$;Double)))] + (|>> inputI ($i.unwrap #$.Double) + paramI ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" <method> math-binary-method false) + ($i.wrap #$.Double)))] [math//atan2 "atan2"] [math//pow "pow"] @@ -499,90 +499,90 @@ (def: (math//round inputI) Unary - (|>. inputI - ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false) - $i;L2D - ($i;wrap #$;Double))) + (|>> inputI + ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" "round" ($t.method (list $t.double) (#.Some $t.long) (list)) false) + $i.L2D + ($i.wrap #$.Double))) ## [[IO]] -(def: string-method $;Method ($t;method (list $String) #;None (list))) +(def: string-method $.Method ($t.method (list $String) #.None (list))) (def: (io//log messageI) Unary - (|>. ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) + (|>> ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) messageI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) - ($i;string hostL;unit))) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) + ($i.string hostL.unit))) (def: (io//error messageI) Unary - (|>. ($i;NEW "java.lang.Error") - $i;DUP + (|>> ($i.NEW "java.lang.Error") + $i.DUP messageI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKESPECIAL "java.lang.Error" "<init>" string-method false) - $i;ATHROW)) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKESPECIAL "java.lang.Error" "<init>" string-method false) + $i.ATHROW)) (def: (io//exit codeI) Unary - (|>. codeI jvm-intI - ($i;INVOKESTATIC "java.lang.System" "exit" ($t;method (list $t;int) #;None (list)) false) - $i;NULL)) + (|>> codeI jvm-intI + ($i.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) false) + $i.NULL)) (def: (io//current-time []) Nullary - (|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false) - ($i;wrap #$;Long))) + (|>> ($i.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) false) + ($i.wrap #$.Long))) ## [[Atoms]] (def: atom-class Text "java.util.concurrent.atomic.AtomicReference") (def: (atom//new initI) Unary - (|>. ($i;NEW atom-class) - $i;DUP + (|>> ($i.NEW atom-class) + $i.DUP initI - ($i;INVOKESPECIAL atom-class "<init>" ($t;method (list $Object) #;None (list)) false))) + ($i.INVOKESPECIAL atom-class "<init>" ($t.method (list $Object) #.None (list)) false))) (def: (atom//read atomI) Unary - (|>. atomI - ($i;CHECKCAST atom-class) - ($i;INVOKEVIRTUAL atom-class "get" ($t;method (list) (#;Some $Object) (list)) false))) + (|>> atomI + ($i.CHECKCAST atom-class) + ($i.INVOKEVIRTUAL atom-class "get" ($t.method (list) (#.Some $Object) (list)) false))) (def: (atom//compare-and-swap [atomI oldI newI]) Trinary - (|>. atomI - ($i;CHECKCAST atom-class) + (|>> atomI + ($i.CHECKCAST atom-class) oldI newI - ($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false) - ($i;wrap #$;Boolean))) + ($i.INVOKEVIRTUAL atom-class "compareAndSet" ($t.method (list $Object $Object) (#.Some $t.boolean) (list)) false) + ($i.wrap #$.Boolean))) ## [[Processes]] (def: (process//concurrency-level []) Nullary - (|>. ($i;INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t;method (list) (#;Some ($t;class "java.lang.Runtime" (list))) (list)) false) - ($i;INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t;method (list) (#;Some $t;int) (list)) false) + (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false) + ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false) lux-intI)) (def: (process//future procedureI) Unary - (|>. procedureI ($i;CHECKCAST hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "future" - ($t;method (list $Function) (#;Some $Object) (list)) false))) + (|>> 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 hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "schedule" - ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) + (|>> millisecondsI ($i.unwrap #$.Long) + procedureI ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "schedule" + ($t.method (list $t.long $Function) (#.Some $Object) (list)) false))) ## [Bundles] (def: lux-procs Bundle - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) @@ -594,7 +594,7 @@ (def: bit-procs Bundle (<| (prefix "bit") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "count" (unary bit//count)) (install "and" (binary bit//and)) (install "or" (binary bit//or)) @@ -607,7 +607,7 @@ (def: nat-procs Bundle (<| (prefix "nat") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary nat//add)) (install "-" (binary nat//sub)) (install "*" (binary nat//mul)) @@ -623,7 +623,7 @@ (def: int-procs Bundle (<| (prefix "int") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary int//add)) (install "-" (binary int//sub)) (install "*" (binary int//mul)) @@ -639,7 +639,7 @@ (def: deg-procs Bundle (<| (prefix "deg") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary deg//add)) (install "-" (binary deg//sub)) (install "*" (binary deg//mul)) @@ -656,7 +656,7 @@ (def: frac-procs Bundle (<| (prefix "frac") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary frac//add)) (install "-" (binary frac//sub)) (install "*" (binary frac//mul)) @@ -678,7 +678,7 @@ (def: text-procs Bundle (<| (prefix "text") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "=" (binary text//eq)) (install "<" (binary text//lt)) (install "concat" (binary text//concat)) @@ -696,7 +696,7 @@ (def: array-procs Bundle (<| (prefix "array") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" (unary array//new)) (install "get" (binary array//get)) (install "put" (trinary array//put)) @@ -707,7 +707,7 @@ (def: math-procs Bundle (<| (prefix "math") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "cos" (unary math//cos)) (install "sin" (unary math//sin)) (install "tan" (unary math//tan)) @@ -731,7 +731,7 @@ (def: io-procs Bundle (<| (prefix "io") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "log" (unary io//log)) (install "error" (unary io//error)) (install "exit" (unary io//exit)) @@ -740,7 +740,7 @@ (def: atom-procs Bundle (<| (prefix "atom") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" (unary atom//new)) (install "read" (unary atom//read)) (install "compare-and-swap" (trinary atom//compare-and-swap))))) @@ -748,7 +748,7 @@ (def: process-procs Bundle (<| (prefix "process") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "concurrency-level" (nullary process//concurrency-level)) (install "future" (unary process//future)) (install "schedule" (binary process//schedule)) @@ -757,17 +757,17 @@ (def: #export procedures Bundle (<| (prefix "lux") - (|> (dict;new text;Hash<Text>) - (dict;merge lux-procs) - (dict;merge bit-procs) - (dict;merge nat-procs) - (dict;merge int-procs) - (dict;merge deg-procs) - (dict;merge frac-procs) - (dict;merge text-procs) - (dict;merge array-procs) - (dict;merge math-procs) - (dict;merge io-procs) - (dict;merge atom-procs) - (dict;merge process-procs) + (|> (dict.new text.Hash<Text>) + (dict.merge lux-procs) + (dict.merge bit-procs) + (dict.merge nat-procs) + (dict.merge int-procs) + (dict.merge deg-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge array-procs) + (dict.merge math-procs) + (dict.merge io-procs) + (dict.merge atom-procs) + (dict.merge process-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux index 2aa693d2c..f2f88904d 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser "parser/" Monad<Parser>] @@ -15,13 +15,13 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] - (analysis (procedure ["&;" host])) + (analysis (procedure ["&." host])) ["ls" synthesis])) ["@" //common]) @@ -30,732 +30,732 @@ (do-template [<name> <inst>] [(def: <name> - $;Inst + $.Inst <inst>)] - [L2S (|>. $i;L2I $i;I2S)] - [L2B (|>. $i;L2I $i;I2B)] - [L2C (|>. $i;L2I $i;I2C)] + [L2S (|>> $i.L2I $i.I2S)] + [L2B (|>> $i.L2I $i.I2B)] + [L2C (|>> $i.L2I $i.I2C)] ) (do-template [<name> <unwrap> <conversion> <wrap>] [(def: (<name> inputI) - @;Unary - (if (is $i;NOP <conversion>) - (|>. inputI - ($i;unwrap <unwrap>) - ($i;wrap <wrap>)) - (|>. inputI - ($i;unwrap <unwrap>) + @.Unary + (if (is $i.NOP <conversion>) + (|>> inputI + ($i.unwrap <unwrap>) + ($i.wrap <wrap>)) + (|>> inputI + ($i.unwrap <unwrap>) <conversion> - ($i;wrap <wrap>))))] + ($i.wrap <wrap>))))] - [convert//double-to-float #$;Double $i;D2F #$;Float] - [convert//double-to-int #$;Double $i;D2I #$;Int] - [convert//double-to-long #$;Double $i;D2L #$;Long] - [convert//float-to-double #$;Float $i;F2D #$;Double] - [convert//float-to-int #$;Float $i;F2I #$;Int] - [convert//float-to-long #$;Float $i;F2L #$;Long] - [convert//int-to-byte #$;Int $i;I2B #$;Byte] - [convert//int-to-char #$;Int $i;I2C #$;Char] - [convert//int-to-double #$;Int $i;I2D #$;Double] - [convert//int-to-float #$;Int $i;I2F #$;Float] - [convert//int-to-long #$;Int $i;I2L #$;Long] - [convert//int-to-short #$;Int $i;I2S #$;Short] - [convert//long-to-double #$;Long $i;L2D #$;Double] - [convert//long-to-float #$;Long $i;L2F #$;Float] - [convert//long-to-int #$;Long $i;L2I #$;Int] - [convert//long-to-short #$;Long L2S #$;Short] - [convert//long-to-byte #$;Long L2B #$;Byte] - [convert//long-to-char #$;Long L2C #$;Char] - [convert//char-to-byte #$;Char $i;I2B #$;Byte] - [convert//char-to-short #$;Char $i;I2S #$;Short] - [convert//char-to-int #$;Char $i;NOP #$;Int] - [convert//char-to-long #$;Char $i;I2L #$;Long] - [convert//byte-to-long #$;Byte $i;I2L #$;Long] - [convert//short-to-long #$;Short $i;I2L #$;Long] + [convert//double-to-float #$.Double $i.D2F #$.Float] + [convert//double-to-int #$.Double $i.D2I #$.Int] + [convert//double-to-long #$.Double $i.D2L #$.Long] + [convert//float-to-double #$.Float $i.F2D #$.Double] + [convert//float-to-int #$.Float $i.F2I #$.Int] + [convert//float-to-long #$.Float $i.F2L #$.Long] + [convert//int-to-byte #$.Int $i.I2B #$.Byte] + [convert//int-to-char #$.Int $i.I2C #$.Char] + [convert//int-to-double #$.Int $i.I2D #$.Double] + [convert//int-to-float #$.Int $i.I2F #$.Float] + [convert//int-to-long #$.Int $i.I2L #$.Long] + [convert//int-to-short #$.Int $i.I2S #$.Short] + [convert//long-to-double #$.Long $i.L2D #$.Double] + [convert//long-to-float #$.Long $i.L2F #$.Float] + [convert//long-to-int #$.Long $i.L2I #$.Int] + [convert//long-to-short #$.Long L2S #$.Short] + [convert//long-to-byte #$.Long L2B #$.Byte] + [convert//long-to-char #$.Long L2C #$.Char] + [convert//char-to-byte #$.Char $i.I2B #$.Byte] + [convert//char-to-short #$.Char $i.I2S #$.Short] + [convert//char-to-int #$.Char $i.NOP #$.Int] + [convert//char-to-long #$.Char $i.I2L #$.Long] + [convert//byte-to-long #$.Byte $i.I2L #$.Long] + [convert//short-to-long #$.Short $i.I2L #$.Long] ) (def: conversion-procs - @;Bundle - (<| (@;prefix "convert") - (|> (dict;new text;Hash<Text>) - (@;install "double-to-float" (@;unary convert//double-to-float)) - (@;install "double-to-int" (@;unary convert//double-to-int)) - (@;install "double-to-long" (@;unary convert//double-to-long)) - (@;install "float-to-double" (@;unary convert//float-to-double)) - (@;install "float-to-int" (@;unary convert//float-to-int)) - (@;install "float-to-long" (@;unary convert//float-to-long)) - (@;install "int-to-byte" (@;unary convert//int-to-byte)) - (@;install "int-to-char" (@;unary convert//int-to-char)) - (@;install "int-to-double" (@;unary convert//int-to-double)) - (@;install "int-to-float" (@;unary convert//int-to-float)) - (@;install "int-to-long" (@;unary convert//int-to-long)) - (@;install "int-to-short" (@;unary convert//int-to-short)) - (@;install "long-to-double" (@;unary convert//long-to-double)) - (@;install "long-to-float" (@;unary convert//long-to-float)) - (@;install "long-to-int" (@;unary convert//long-to-int)) - (@;install "long-to-short" (@;unary convert//long-to-short)) - (@;install "long-to-byte" (@;unary convert//long-to-byte)) - (@;install "long-to-char" (@;unary convert//long-to-char)) - (@;install "char-to-byte" (@;unary convert//char-to-byte)) - (@;install "char-to-short" (@;unary convert//char-to-short)) - (@;install "char-to-int" (@;unary convert//char-to-int)) - (@;install "char-to-long" (@;unary convert//char-to-long)) - (@;install "byte-to-long" (@;unary convert//byte-to-long)) - (@;install "short-to-long" (@;unary convert//short-to-long)) + @.Bundle + (<| (@.prefix "convert") + (|> (dict.new text.Hash<Text>) + (@.install "double-to-float" (@.unary convert//double-to-float)) + (@.install "double-to-int" (@.unary convert//double-to-int)) + (@.install "double-to-long" (@.unary convert//double-to-long)) + (@.install "float-to-double" (@.unary convert//float-to-double)) + (@.install "float-to-int" (@.unary convert//float-to-int)) + (@.install "float-to-long" (@.unary convert//float-to-long)) + (@.install "int-to-byte" (@.unary convert//int-to-byte)) + (@.install "int-to-char" (@.unary convert//int-to-char)) + (@.install "int-to-double" (@.unary convert//int-to-double)) + (@.install "int-to-float" (@.unary convert//int-to-float)) + (@.install "int-to-long" (@.unary convert//int-to-long)) + (@.install "int-to-short" (@.unary convert//int-to-short)) + (@.install "long-to-double" (@.unary convert//long-to-double)) + (@.install "long-to-float" (@.unary convert//long-to-float)) + (@.install "long-to-int" (@.unary convert//long-to-int)) + (@.install "long-to-short" (@.unary convert//long-to-short)) + (@.install "long-to-byte" (@.unary convert//long-to-byte)) + (@.install "long-to-char" (@.unary convert//long-to-char)) + (@.install "char-to-byte" (@.unary convert//char-to-byte)) + (@.install "char-to-short" (@.unary convert//char-to-short)) + (@.install "char-to-int" (@.unary convert//char-to-int)) + (@.install "char-to-long" (@.unary convert//char-to-long)) + (@.install "byte-to-long" (@.unary convert//byte-to-long)) + (@.install "short-to-long" (@.unary convert//short-to-long)) ))) (do-template [<name> <op> <unwrapX> <unwrapY> <wrap>] [(def: (<name> [xI yI]) - @;Binary - (|>. xI ($i;unwrap <unwrapX>) - yI ($i;unwrap <unwrapY>) - <op> ($i;wrap <wrap>)))] - - [int//+ $i;IADD #$;Int #$;Int #$;Int] - [int//- $i;ISUB #$;Int #$;Int #$;Int] - [int//* $i;IMUL #$;Int #$;Int #$;Int] - [int/// $i;IDIV #$;Int #$;Int #$;Int] - [int//% $i;IREM #$;Int #$;Int #$;Int] - [int//and $i;IAND #$;Int #$;Int #$;Int] - [int//or $i;IOR #$;Int #$;Int #$;Int] - [int//xor $i;IXOR #$;Int #$;Int #$;Int] - [int//shl $i;ISHL #$;Int #$;Int #$;Int] - [int//shr $i;ISHR #$;Int #$;Int #$;Int] - [int//ushr $i;IUSHR #$;Int #$;Int #$;Int] + @.Binary + (|>> xI ($i.unwrap <unwrapX>) + yI ($i.unwrap <unwrapY>) + <op> ($i.wrap <wrap>)))] + + [int//+ $i.IADD #$.Int #$.Int #$.Int] + [int//- $i.ISUB #$.Int #$.Int #$.Int] + [int//* $i.IMUL #$.Int #$.Int #$.Int] + [int/// $i.IDIV #$.Int #$.Int #$.Int] + [int//% $i.IREM #$.Int #$.Int #$.Int] + [int//and $i.IAND #$.Int #$.Int #$.Int] + [int//or $i.IOR #$.Int #$.Int #$.Int] + [int//xor $i.IXOR #$.Int #$.Int #$.Int] + [int//shl $i.ISHL #$.Int #$.Int #$.Int] + [int//shr $i.ISHR #$.Int #$.Int #$.Int] + [int//ushr $i.IUSHR #$.Int #$.Int #$.Int] - [long//+ $i;LADD #$;Long #$;Long #$;Long] - [long//- $i;LSUB #$;Long #$;Long #$;Long] - [long//* $i;LMUL #$;Long #$;Long #$;Long] - [long/// $i;LDIV #$;Long #$;Long #$;Long] - [long//% $i;LREM #$;Long #$;Long #$;Long] - [long//and $i;LAND #$;Long #$;Long #$;Long] - [long//or $i;LOR #$;Long #$;Long #$;Long] - [long//xor $i;LXOR #$;Long #$;Long #$;Long] - [long//shl $i;LSHL #$;Long #$;Int #$;Long] - [long//shr $i;LSHR #$;Long #$;Int #$;Long] - [long//ushr $i;LUSHR #$;Long #$;Int #$;Long] - - [float//+ $i;FADD #$;Float #$;Float #$;Float] - [float//- $i;FSUB #$;Float #$;Float #$;Float] - [float//* $i;FMUL #$;Float #$;Float #$;Float] - [float/// $i;FDIV #$;Float #$;Float #$;Float] - [float//% $i;FREM #$;Float #$;Float #$;Float] + [long//+ $i.LADD #$.Long #$.Long #$.Long] + [long//- $i.LSUB #$.Long #$.Long #$.Long] + [long//* $i.LMUL #$.Long #$.Long #$.Long] + [long/// $i.LDIV #$.Long #$.Long #$.Long] + [long//% $i.LREM #$.Long #$.Long #$.Long] + [long//and $i.LAND #$.Long #$.Long #$.Long] + [long//or $i.LOR #$.Long #$.Long #$.Long] + [long//xor $i.LXOR #$.Long #$.Long #$.Long] + [long//shl $i.LSHL #$.Long #$.Int #$.Long] + [long//shr $i.LSHR #$.Long #$.Int #$.Long] + [long//ushr $i.LUSHR #$.Long #$.Int #$.Long] + + [float//+ $i.FADD #$.Float #$.Float #$.Float] + [float//- $i.FSUB #$.Float #$.Float #$.Float] + [float//* $i.FMUL #$.Float #$.Float #$.Float] + [float/// $i.FDIV #$.Float #$.Float #$.Float] + [float//% $i.FREM #$.Float #$.Float #$.Float] - [double//+ $i;DADD #$;Double #$;Double #$;Double] - [double//- $i;DSUB #$;Double #$;Double #$;Double] - [double//* $i;DMUL #$;Double #$;Double #$;Double] - [double/// $i;DDIV #$;Double #$;Double #$;Double] - [double//% $i;DREM #$;Double #$;Double #$;Double] + [double//+ $i.DADD #$.Double #$.Double #$.Double] + [double//- $i.DSUB #$.Double #$.Double #$.Double] + [double//* $i.DMUL #$.Double #$.Double #$.Double] + [double/// $i.DDIV #$.Double #$.Double #$.Double] + [double//% $i.DREM #$.Double #$.Double #$.Double] ) (do-template [<name> <op> <unwrapX> <unwrapY> <wrap>] [(def: (<name> [xI yI]) - @;Binary - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. xI ($i;unwrap <unwrapX>) - yI ($i;unwrap <unwrapY>) + @.Binary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> xI ($i.unwrap <unwrapX>) + yI ($i.unwrap <unwrapY>) (<op> @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end))))] + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end))))] - [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean] - [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean] + [int//= $i.IF_ICMPEQ #$.Int #$.Int #$.Boolean] + [int//< $i.IF_ICMPLT #$.Int #$.Int #$.Boolean] - [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean] - [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean] + [char//= $i.IF_ICMPEQ #$.Char #$.Char #$.Boolean] + [char//< $i.IF_ICMPLT #$.Char #$.Char #$.Boolean] ) (do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>] [(def: (<name> [xI yI]) - @;Binary - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. xI ($i;unwrap <unwrapX>) - yI ($i;unwrap <unwrapY>) + @.Binary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> xI ($i.unwrap <unwrapX>) + yI ($i.unwrap <unwrapY>) <op> - ($i;int <reference>) - ($i;IF_ICMPEQ @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end))))] - - [long//= $i;LCMP 0 #$;Long #$;Long #$;Boolean] - [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean] + ($i.int <reference>) + ($i.IF_ICMPEQ @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end))))] + + [long//= $i.LCMP 0 #$.Long #$.Long #$.Boolean] + [long//< $i.LCMP -1 #$.Long #$.Long #$.Boolean] - [float//= $i;FCMPG 0 #$;Float #$;Float #$;Boolean] - [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean] + [float//= $i.FCMPG 0 #$.Float #$.Float #$.Boolean] + [float//< $i.FCMPG -1 #$.Float #$.Float #$.Boolean] - [double//= $i;DCMPG 0 #$;Double #$;Double #$;Boolean] - [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean] + [double//= $i.DCMPG 0 #$.Double #$.Double #$.Boolean] + [double//< $i.DCMPG -1 #$.Double #$.Double #$.Boolean] ) (def: int-procs - @;Bundle - (<| (@;prefix "int") - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary int//+)) - (@;install "-" (@;binary int//-)) - (@;install "*" (@;binary int//*)) - (@;install "/" (@;binary int///)) - (@;install "%" (@;binary int//%)) - (@;install "=" (@;binary int//=)) - (@;install "<" (@;binary int//<)) - (@;install "and" (@;binary int//and)) - (@;install "or" (@;binary int//or)) - (@;install "xor" (@;binary int//xor)) - (@;install "shl" (@;binary int//shl)) - (@;install "shr" (@;binary int//shr)) - (@;install "ushr" (@;binary int//ushr)) + @.Bundle + (<| (@.prefix "int") + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary int//+)) + (@.install "-" (@.binary int//-)) + (@.install "*" (@.binary int//*)) + (@.install "/" (@.binary int///)) + (@.install "%" (@.binary int//%)) + (@.install "=" (@.binary int//=)) + (@.install "<" (@.binary int//<)) + (@.install "and" (@.binary int//and)) + (@.install "or" (@.binary int//or)) + (@.install "xor" (@.binary int//xor)) + (@.install "shl" (@.binary int//shl)) + (@.install "shr" (@.binary int//shr)) + (@.install "ushr" (@.binary int//ushr)) ))) (def: long-procs - @;Bundle - (<| (@;prefix "long") - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary long//+)) - (@;install "-" (@;binary long//-)) - (@;install "*" (@;binary long//*)) - (@;install "/" (@;binary long///)) - (@;install "%" (@;binary long//%)) - (@;install "=" (@;binary long//=)) - (@;install "<" (@;binary long//<)) - (@;install "and" (@;binary long//and)) - (@;install "or" (@;binary long//or)) - (@;install "xor" (@;binary long//xor)) - (@;install "shl" (@;binary long//shl)) - (@;install "shr" (@;binary long//shr)) - (@;install "ushr" (@;binary long//ushr)) + @.Bundle + (<| (@.prefix "long") + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary long//+)) + (@.install "-" (@.binary long//-)) + (@.install "*" (@.binary long//*)) + (@.install "/" (@.binary long///)) + (@.install "%" (@.binary long//%)) + (@.install "=" (@.binary long//=)) + (@.install "<" (@.binary long//<)) + (@.install "and" (@.binary long//and)) + (@.install "or" (@.binary long//or)) + (@.install "xor" (@.binary long//xor)) + (@.install "shl" (@.binary long//shl)) + (@.install "shr" (@.binary long//shr)) + (@.install "ushr" (@.binary long//ushr)) ))) (def: float-procs - @;Bundle - (<| (@;prefix "float") - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary float//+)) - (@;install "-" (@;binary float//-)) - (@;install "*" (@;binary float//*)) - (@;install "/" (@;binary float///)) - (@;install "%" (@;binary float//%)) - (@;install "=" (@;binary float//=)) - (@;install "<" (@;binary float//<)) + @.Bundle + (<| (@.prefix "float") + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary float//+)) + (@.install "-" (@.binary float//-)) + (@.install "*" (@.binary float//*)) + (@.install "/" (@.binary float///)) + (@.install "%" (@.binary float//%)) + (@.install "=" (@.binary float//=)) + (@.install "<" (@.binary float//<)) ))) (def: double-procs - @;Bundle - (<| (@;prefix "double") - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary double//+)) - (@;install "-" (@;binary double//-)) - (@;install "*" (@;binary double//*)) - (@;install "/" (@;binary double///)) - (@;install "%" (@;binary double//%)) - (@;install "=" (@;binary double//=)) - (@;install "<" (@;binary double//<)) + @.Bundle + (<| (@.prefix "double") + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary double//+)) + (@.install "-" (@.binary double//-)) + (@.install "*" (@.binary double//*)) + (@.install "/" (@.binary double///)) + (@.install "%" (@.binary double//%)) + (@.install "=" (@.binary double//=)) + (@.install "<" (@.binary double//<)) ))) (def: char-procs - @;Bundle - (<| (@;prefix "char") - (|> (dict;new text;Hash<Text>) - (@;install "=" (@;binary char//=)) - (@;install "<" (@;binary char//<)) + @.Bundle + (<| (@.prefix "char") + (|> (dict.new text.Hash<Text>) + (@.install "=" (@.binary char//=)) + (@.install "<" (@.binary char//<)) ))) (def: (array//length arrayI) - @;Unary - (|>. arrayI - $i;ARRAYLENGTH - $i;I2L - ($i;wrap #$;Long))) + @.Unary + (|>> arrayI + $i.ARRAYLENGTH + $i.I2L + ($i.wrap #$.Long))) (def: (array//new proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) + (do macro.Monad<Meta> [lengthI (translate lengthS) - #let [arrayJT ($t;array level (case class - "boolean" $t;boolean - "byte" $t;byte - "short" $t;short - "int" $t;int - "long" $t;long - "float" $t;float - "double" $t;double - "char" $t;char - _ ($t;class class (list))))]] - (wrap (|>. lengthI - ($i;unwrap #$;Long) - $i;L2I - ($i;array arrayJT)))) + #let [arrayJT ($t.array level (case class + "boolean" $t.boolean + "byte" $t.byte + "short" $t.short + "int" $t.int + "long" $t.long + "float" $t.float + "double" $t.double + "char" $t.char + _ ($t.class class (list))))]] + (wrap (|>> lengthI + ($i.unwrap #$.Long) + $i.L2I + ($i.array arrayJT)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (array//read proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] idxS arrayS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] idxS arrayS)) + (do macro.Monad<Meta> [arrayI (translate arrayS) idxI (translate idxS) #let [loadI (case class - "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean)) - "byte" (|>. $i;BALOAD ($i;wrap #$;Byte)) - "short" (|>. $i;SALOAD ($i;wrap #$;Short)) - "int" (|>. $i;IALOAD ($i;wrap #$;Int)) - "long" (|>. $i;LALOAD ($i;wrap #$;Long)) - "float" (|>. $i;FALOAD ($i;wrap #$;Float)) - "double" (|>. $i;DALOAD ($i;wrap #$;Double)) - "char" (|>. $i;CALOAD ($i;wrap #$;Char)) - _ $i;AALOAD)]] - (wrap (|>. arrayI + "boolean" (|>> $i.BALOAD ($i.wrap #$.Boolean)) + "byte" (|>> $i.BALOAD ($i.wrap #$.Byte)) + "short" (|>> $i.SALOAD ($i.wrap #$.Short)) + "int" (|>> $i.IALOAD ($i.wrap #$.Int)) + "long" (|>> $i.LALOAD ($i.wrap #$.Long)) + "float" (|>> $i.FALOAD ($i.wrap #$.Float)) + "double" (|>> $i.DALOAD ($i.wrap #$.Double)) + "char" (|>> $i.CALOAD ($i.wrap #$.Char)) + _ $i.AALOAD)]] + (wrap (|>> arrayI idxI - ($i;unwrap #$;Long) - $i;L2I + ($i.unwrap #$.Long) + $i.L2I loadI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (array//write proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] idxS valueS arrayS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] idxS valueS arrayS)) + (do macro.Monad<Meta> [arrayI (translate arrayS) idxI (translate idxS) valueI (translate valueS) #let [storeI (case class - "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE) - "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE) - "short" (|>. ($i;unwrap #$;Short) $i;SASTORE) - "int" (|>. ($i;unwrap #$;Int) $i;IASTORE) - "long" (|>. ($i;unwrap #$;Long) $i;LASTORE) - "float" (|>. ($i;unwrap #$;Float) $i;FASTORE) - "double" (|>. ($i;unwrap #$;Double) $i;DASTORE) - "char" (|>. ($i;unwrap #$;Char) $i;CASTORE) - _ $i;AASTORE)]] - (wrap (|>. arrayI - $i;DUP + "boolean" (|>> ($i.unwrap #$.Boolean) $i.BASTORE) + "byte" (|>> ($i.unwrap #$.Byte) $i.BASTORE) + "short" (|>> ($i.unwrap #$.Short) $i.SASTORE) + "int" (|>> ($i.unwrap #$.Int) $i.IASTORE) + "long" (|>> ($i.unwrap #$.Long) $i.LASTORE) + "float" (|>> ($i.unwrap #$.Float) $i.FASTORE) + "double" (|>> ($i.unwrap #$.Double) $i.DASTORE) + "char" (|>> ($i.unwrap #$.Char) $i.CASTORE) + _ $i.AASTORE)]] + (wrap (|>> arrayI + $i.DUP idxI - ($i;unwrap #$;Long) - $i;L2I + ($i.unwrap #$.Long) + $i.L2I valueI storeI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: array-procs - @;Bundle - (<| (@;prefix "array") - (|> (dict;new text;Hash<Text>) - (@;install "length" (@;unary array//length)) - (@;install "new" array//new) - (@;install "read" array//read) - (@;install "write" array//write) + @.Bundle + (<| (@.prefix "array") + (|> (dict.new text.Hash<Text>) + (@.install "length" (@.unary array//length)) + (@.install "new" array//new) + (@.install "read" array//read) + (@.install "write" array//write) ))) (def: (object//null _) - @;Nullary - $i;NULL) + @.Nullary + $i.NULL) (def: (object//null? objectI) - @;Unary - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. objectI - ($i;IFNULL @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end)))) + @.Unary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> objectI + ($i.IFNULL @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end)))) (def: (object//synchronized [monitorI exprI]) - @;Binary - (|>. monitorI - $i;DUP - $i;MONITORENTER + @.Binary + (|>> monitorI + $i.DUP + $i.MONITORENTER exprI - $i;SWAP - $i;MONITOREXIT)) + $i.SWAP + $i.MONITOREXIT)) (def: (object//throw exceptionI) - @;Unary - (|>. exceptionI - $i;ATHROW)) + @.Unary + (|>> exceptionI + $i.ATHROW)) (def: (object//class proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)])) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)])) + (do macro.Monad<Meta> [] - (wrap (|>. ($i;string class) - ($i;INVOKESTATIC "java.lang.Class" "forName" - ($t;method (list ($t;class "java.lang.String" (list))) - (#;Some ($t;class "java.lang.Class" (list))) + (wrap (|>> ($i.string class) + ($i.INVOKESTATIC "java.lang.Class" "forName" + ($t.method (list ($t.class "java.lang.String" (list))) + (#.Some ($t.class "java.lang.Class" (list))) (list)) false)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (object//instance? proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] objectS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] objectS)) + (do macro.Monad<Meta> [objectI (translate objectS)] - (wrap (|>. objectI - ($i;INSTANCEOF class) - ($i;wrap #$;Boolean)))) + (wrap (|>> objectI + ($i.INSTANCEOF class) + ($i.wrap #$.Boolean)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: object-procs - @;Bundle - (<| (@;prefix "object") - (|> (dict;new text;Hash<Text>) - (@;install "null" (@;nullary object//null)) - (@;install "null?" (@;unary object//null?)) - (@;install "synchronized" (@;binary object//synchronized)) - (@;install "throw" (@;unary object//throw)) - (@;install "class" object//class) - (@;install "instance?" object//instance?) + @.Bundle + (<| (@.prefix "object") + (|> (dict.new text.Hash<Text>) + (@.install "null" (@.nullary object//null)) + (@.install "null?" (@.unary object//null?)) + (@.install "synchronized" (@.binary object//synchronized)) + (@.install "throw" (@.unary object//throw)) + (@.install "class" object//class) + (@.install "instance?" object//instance?) ))) (def: primitives - (Dict Text $;Primitive) - (|> (list ["boolean" #$;Boolean] - ["byte" #$;Byte] - ["short" #$;Short] - ["int" #$;Int] - ["long" #$;Long] - ["float" #$;Float] - ["double" #$;Double] - ["char" #$;Char]) - (dict;from-list text;Hash<Text>))) + (Dict Text $.Primitive) + (|> (list ["boolean" #$.Boolean] + ["byte" #$.Byte] + ["short" #$.Short] + ["int" #$.Int] + ["long" #$.Long] + ["float" #$.Float] + ["double" #$.Double] + ["char" #$.Char]) + (dict.from-list text.Hash<Text>))) (def: (static//get proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) + (do macro.Monad<Meta> [] - (case (dict;get unboxed primitives) - (#;Some primitive) + (case (dict.get unboxed primitives) + (#.Some primitive) (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char _ (undefined))] - (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive)) - ($i;wrap primitive)))) + (wrap (|>> ($i.GETSTATIC class field (#$.Primitive primitive)) + ($i.wrap primitive)))) - #;None - (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) + #.None + (wrap ($i.GETSTATIC class field ($t.class unboxed (list)))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (static//put proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) + (do macro.Monad<Meta> [valueI (translate valueS)] - (case (dict;get unboxed primitives) - (#;Some primitive) + (case (dict.get unboxed primitives) + (#.Some primitive) (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char _ (undefined))] - (wrap (|>. valueI - ($i;unwrap primitive) - ($i;PUTSTATIC class field (#$;Primitive primitive)) - ($i;string hostL;unit)))) + (wrap (|>> valueI + ($i.unwrap primitive) + ($i.PUTSTATIC class field (#$.Primitive primitive)) + ($i.string hostL.unit)))) - #;None - (wrap (|>. valueI - ($i;CHECKCAST class) - ($i;PUTSTATIC class field ($t;class class (list))) - ($i;string hostL;unit))))) + #.None + (wrap (|>> valueI + ($i.CHECKCAST class) + ($i.PUTSTATIC class field ($t.class class (list))) + ($i.string hostL.unit))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (virtual//get proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) + (do macro.Monad<Meta> [objectI (translate objectS)] - (case (dict;get unboxed primitives) - (#;Some primitive) + (case (dict.get unboxed primitives) + (#.Some primitive) (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char _ (undefined))] - (wrap (|>. objectI - ($i;CHECKCAST class) - ($i;GETFIELD class field (#$;Primitive primitive)) - ($i;wrap primitive)))) + (wrap (|>> objectI + ($i.CHECKCAST class) + ($i.GETFIELD class field (#$.Primitive primitive)) + ($i.wrap primitive)))) - #;None - (wrap (|>. objectI - ($i;CHECKCAST class) - ($i;GETFIELD class field ($t;class unboxed (list))))))) + #.None + (wrap (|>> objectI + ($i.CHECKCAST class) + ($i.GETFIELD class field ($t.class unboxed (list))))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (virtual//put proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) + (do macro.Monad<Meta> [valueI (translate valueS) objectI (translate objectS)] - (case (dict;get unboxed primitives) - (#;Some primitive) + (case (dict.get unboxed primitives) + (#.Some primitive) (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char _ (undefined))] - (wrap (|>. objectI - ($i;CHECKCAST class) - $i;DUP + (wrap (|>> objectI + ($i.CHECKCAST class) + $i.DUP valueI - ($i;unwrap primitive) - ($i;PUTFIELD class field (#$;Primitive primitive))))) + ($i.unwrap primitive) + ($i.PUTFIELD class field (#$.Primitive primitive))))) - #;None - (wrap (|>. objectI - ($i;CHECKCAST class) - $i;DUP + #.None + (wrap (|>> objectI + ($i.CHECKCAST class) + $i.DUP valueI - ($i;CHECKCAST unboxed) - ($i;PUTFIELD class field ($t;class unboxed (list))))))) + ($i.CHECKCAST unboxed) + ($i.PUTFIELD class field ($t.class unboxed (list))))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: base-type - (l;Lexer $;Type) - ($_ p;either - (p;after (l;this "boolean") (parser/wrap $t;boolean)) - (p;after (l;this "byte") (parser/wrap $t;byte)) - (p;after (l;this "short") (parser/wrap $t;short)) - (p;after (l;this "int") (parser/wrap $t;int)) - (p;after (l;this "long") (parser/wrap $t;long)) - (p;after (l;this "float") (parser/wrap $t;float)) - (p;after (l;this "double") (parser/wrap $t;double)) - (p;after (l;this "char") (parser/wrap $t;char)) + (l.Lexer $.Type) + ($_ p.either + (p.after (l.this "boolean") (parser/wrap $t.boolean)) + (p.after (l.this "byte") (parser/wrap $t.byte)) + (p.after (l.this "short") (parser/wrap $t.short)) + (p.after (l.this "int") (parser/wrap $t.int)) + (p.after (l.this "long") (parser/wrap $t.long)) + (p.after (l.this "float") (parser/wrap $t.float)) + (p.after (l.this "double") (parser/wrap $t.double)) + (p.after (l.this "char") (parser/wrap $t.char)) (parser/map (function [name] - ($t;class name (list))) - (l;many (l;none-of "["))) + ($t.class name (list))) + (l.many (l.none-of "["))) )) (def: java-type - (l;Lexer $;Type) - (do p;Monad<Parser> + (l.Lexer $.Type) + (do p.Monad<Parser> [raw base-type - nesting (p;some (l;this "[]"))] - (wrap ($t;array (list;size nesting) raw)))) + nesting (p.some (l.this "[]"))] + (wrap ($t.array (list.size nesting) raw)))) (def: (translate-type argD) - (-> Text (Meta $;Type)) - (case (l;run argD java-type) - (#e;Error error) - (&;throw Invalid-Syntax-For-JVM-Type argD) + (-> Text (Meta $.Type)) + (case (l.run argD java-type) + (#e.Error error) + (&.throw Invalid-Syntax-For-JVM-Type argD) - (#e;Success type) + (#e.Success type) (macro/wrap type))) (def: (prepare-input inputT inputI) - (-> $;Type $;Inst $;Inst) + (-> $.Type $.Inst $.Inst) (case inputT - (#$;Primitive primitive) - (|>. inputI ($i;unwrap primitive)) + (#$.Primitive primitive) + (|>> inputI ($i.unwrap primitive)) - (#$;Generic generic) + (#$.Generic generic) (case generic - (^or (#$;Var _) (#$;Wildcard _)) - (|>. inputI ($i;CHECKCAST "java.lang.Object")) + (^or (#$.Var _) (#$.Wildcard _)) + (|>> inputI ($i.CHECKCAST "java.lang.Object")) - (#$;Class class-name _) - (|>. inputI ($i;CHECKCAST class-name))) + (#$.Class class-name _) + (|>> inputI ($i.CHECKCAST class-name))) _ - (|>. inputI ($i;CHECKCAST ($t;descriptor inputT))))) + (|>> inputI ($i.CHECKCAST ($t.descriptor inputT))))) (def: (translate-args translate argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) - (Meta (List [$;Type $;Inst]))) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) + (Meta (List [$.Type $.Inst]))) (case argsS - #;Nil - (macro/wrap #;Nil) + #.Nil + (macro/wrap #.Nil) - (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail)) + (do macro.Monad<Meta> [argT (translate-type argD) argI (:: @ map (prepare-input argT) (translate argS)) =tail (translate-args translate tail)] (wrap (list& [argT argI] =tail))) _ - (&;throw Invalid-Syntax-For-Argument-Generation ""))) + (&.throw Invalid-Syntax-For-Argument-Generation ""))) (def: (method-return-type description) - (-> Text (Meta (Maybe $;Type))) + (-> Text (Meta (Maybe $.Type))) (case description "void" - (macro/wrap #;None) + (macro/wrap #.None) _ - (macro/map (|>. #;Some) (translate-type description)))) + (macro/map (|>> #.Some) (translate-type description)))) (def: (prepare-return returnT returnI) - (-> (Maybe $;Type) $;Inst $;Inst) + (-> (Maybe $.Type) $.Inst $.Inst) (case returnT - #;None - (|>. returnI - ($i;string hostL;unit)) + #.None + (|>> returnI + ($i.string hostL.unit)) - (#;Some type) + (#.Some type) (case type - (#$;Primitive primitive) - (|>. returnI ($i;wrap primitive)) + (#$.Primitive primitive) + (|>> returnI ($i.wrap primitive)) _ returnI))) (def: (invoke//static proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list& [_ (#;Text class)] [_ (#;Text method)] - [_ (#;Text unboxed)] argsS)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] argsS)) + (do macro.Monad<Meta> [argsTI (translate-args translate argsS) returnT (method-return-type unboxed) - #let [callI (|>. ($i;fuse (list/map product;right argsTI)) - ($i;INVOKESTATIC class method - ($t;method (list/map product;left argsTI) returnT (list)) + #let [callI (|>> ($i.fuse (list/map product.right argsTI)) + ($i.INVOKESTATIC class method + ($t.method (list/map product.left argsTI) returnT (list)) false))]] (wrap (prepare-return returnT callI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (do-template [<name> <invoke> <interface?>] [(def: (<name> proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list& [_ (#;Text class)] [_ (#;Text method)] - [_ (#;Text unboxed)] objectS argsS)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] objectS argsS)) + (do macro.Monad<Meta> [objectI (translate objectS) argsTI (translate-args translate argsS) returnT (method-return-type unboxed) - #let [callI (|>. objectI - ($i;CHECKCAST class) - ($i;fuse (list/map product;right argsTI)) + #let [callI (|>> objectI + ($i.CHECKCAST class) + ($i.fuse (list/map product.right argsTI)) (<invoke> class method - ($t;method (list/map product;left argsTI) returnT (list)) + ($t.method (list/map product.left argsTI) returnT (list)) <interface?>))]] (wrap (prepare-return returnT callI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))] + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] - [invoke//virtual $i;INVOKEVIRTUAL false] - [invoke//special $i;INVOKESPECIAL false] - [invoke//interface $i;INVOKEINTERFACE true] + [invoke//virtual $i.INVOKEVIRTUAL false] + [invoke//special $i.INVOKESPECIAL false] + [invoke//interface $i.INVOKEINTERFACE true] ) (def: (invoke//constructor proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list& [_ (#;Text class)] argsS)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Text class)] argsS)) + (do macro.Monad<Meta> [argsTI (translate-args translate argsS)] - (wrap (|>. ($i;NEW class) - $i;DUP - ($i;fuse (list/map product;right argsTI)) - ($i;INVOKESPECIAL class "<init>" - ($t;method (list/map product;left argsTI) #;None (list)) + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse (list/map product.right argsTI)) + ($i.INVOKESPECIAL class "<init>" + ($t.method (list/map product.left argsTI) #.None (list)) false)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: member-procs - @;Bundle - (<| (@;prefix "member") - (|> (dict;new text;Hash<Text>) - (dict;merge (<| (@;prefix "static") - (|> (dict;new text;Hash<Text>) - (@;install "get" static//get) - (@;install "put" static//put)))) - (dict;merge (<| (@;prefix "virtual") - (|> (dict;new text;Hash<Text>) - (@;install "get" virtual//get) - (@;install "put" virtual//put)))) - (dict;merge (<| (@;prefix "invoke") - (|> (dict;new text;Hash<Text>) - (@;install "static" invoke//static) - (@;install "virtual" invoke//virtual) - (@;install "special" invoke//special) - (@;install "interface" invoke//interface) - (@;install "constructor" invoke//constructor)))) + @.Bundle + (<| (@.prefix "member") + (|> (dict.new text.Hash<Text>) + (dict.merge (<| (@.prefix "static") + (|> (dict.new text.Hash<Text>) + (@.install "get" static//get) + (@.install "put" static//put)))) + (dict.merge (<| (@.prefix "virtual") + (|> (dict.new text.Hash<Text>) + (@.install "get" virtual//get) + (@.install "put" virtual//put)))) + (dict.merge (<| (@.prefix "invoke") + (|> (dict.new text.Hash<Text>) + (@.install "static" invoke//static) + (@.install "virtual" invoke//virtual) + (@.install "special" invoke//special) + (@.install "interface" invoke//interface) + (@.install "constructor" invoke//constructor)))) ))) (def: #export procedures - @;Bundle - (<| (@;prefix "jvm") - (|> (dict;new text;Hash<Text>) - (dict;merge conversion-procs) - (dict;merge int-procs) - (dict;merge long-procs) - (dict;merge float-procs) - (dict;merge double-procs) - (dict;merge char-procs) - (dict;merge array-procs) - (dict;merge object-procs) - (dict;merge member-procs) + @.Bundle + (<| (@.prefix "jvm") + (|> (dict.new text.Hash<Text>) + (dict.merge conversion-procs) + (dict.merge int-procs) + (dict.merge long-procs) + (dict.merge float-procs) + (dict.merge double-procs) + (dict.merge char-procs) + (dict.merge array-procs) + (dict.merge object-procs) + (dict.merge member-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux index bfc838041..bfb5856d4 100644 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -1,17 +1,17 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data [text "text/" Hash<Text>] text/format) [macro "macro/" Monad<Meta>]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$i" inst])) ["ls" synthesis] - [";L" variable #+ Variable] - (translation [";T" common])))) + [".L" variable #+ Variable] + (translation [".T" common])))) (do-template [<name> <prefix>] [(def: #export (<name> idx) @@ -23,27 +23,27 @@ ) (def: #export (translate-captured variable) - (-> Variable (Meta $;Inst)) - (do macro;Monad<Meta> - [this-module macro;current-module-name - function-class hostL;context - #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]] - (wrap (|>. ($i;ALOAD +0) - ($i;GETFIELD function-class - (|> variable i.inc (i.* -1) int-to-nat captured) - commonT;$Object))))) + (-> Variable (Meta $.Inst)) + (do macro.Monad<Meta> + [this-module macro.current-module-name + function-class hostL.context + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]] + (wrap (|>> ($i.ALOAD +0) + ($i.GETFIELD function-class + (|> variable i/inc (i/* -1) int-to-nat captured) + commonT.$Object))))) (def: #export (translate-local variable) - (-> Variable (Meta $;Inst)) - (macro/wrap ($i;ALOAD (int-to-nat variable)))) + (-> Variable (Meta $.Inst)) + (macro/wrap ($i.ALOAD (int-to-nat variable)))) (def: #export (translate-variable variable) - (-> Variable (Meta $;Inst)) - (if (variableL;captured? 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) (%n (text/hash def-name)))] - (macro/wrap ($i;GETSTATIC bytecode-name commonT;value-field commonT;$Object)))) + (-> Ident (Meta $.Inst)) + (let [bytecode-name (format def-module "/" (&.normalize-name def-name) (%n (text/hash def-name)))] + (macro/wrap ($i.GETSTATIC bytecode-name commonT.value-field commonT.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux index d2bb1645b..aa210718b 100644 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -1,371 +1,347 @@ -(;module: +(.module: lux (lux (control monad) (data text/format (coll [list "list/" Functor<List>])) [math] - [macro] - [host]) + [macro]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])))) + (translation [".T" common])))) -(host;import java.lang.Object) -(host;import java.lang.String) - -(host;import java.lang.reflect.Field - (get [Object] #try Object)) - -(host;import (java.lang.Class a) - (getField [String] Field)) - -(host;import org.objectweb.asm.Opcodes - (#static ACC_PUBLIC int) - (#static ACC_SUPER int) - (#static ACC_FINAL int) - (#static ACC_STATIC int) - (#static V1_6 int)) - -(host;import org.objectweb.asm.ClassWriter - (#static COMPUTE_MAXS int) - (new [int]) - (visit [int int String String String (Array String)] void) - (visitEnd [] void) - (toByteArray [] (Array byte))) - -(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 $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 hostL;function-class (list))) -(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list))) +(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 $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 hostL.function-class (list))) +(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) (def: #export logI - $;Inst - (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) - printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))] - (|>. outI ($i;string "LOG: ") (printI "print") - outI $i;SWAP (printI "println")))) + $.Inst + (let [outI ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) + printI (function [method] ($i.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) false))] + (|>> outI ($i.string "LOG: ") (printI "print") + outI $i.SWAP (printI "println")))) (def: variant-method - $;Method - ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list))) + $.Method + ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) (def: variantI - $;Inst - ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false)) + $.Inst + ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method false)) (def: #export leftI - $;Inst - (|>. ($i;int 0) - $i;NULL - $i;DUP2_X1 - $i;POP2 + $.Inst + (|>> ($i.int 0) + $i.NULL + $i.DUP2_X1 + $i.POP2 variantI)) (def: #export rightI - $;Inst - (|>. ($i;int 1) - ($i;string "") - $i;DUP2_X1 - $i;POP2 + $.Inst + (|>> ($i.int 1) + ($i.string "") + $i.DUP2_X1 + $i.POP2 variantI)) -(def: #export someI $;Inst rightI) +(def: #export someI $.Inst rightI) (def: #export noneI - $;Inst - (|>. ($i;int 0) - $i;NULL - ($i;string hostL;unit) + $.Inst + (|>> ($i.int 0) + $i.NULL + ($i.string hostL.unit) variantI)) (def: (try-methodI unsafeI) - (-> $;Inst $;Inst) - (<| $i;with-label (function [@from]) - $i;with-label (function [@to]) - $i;with-label (function [@handler]) - (|>. ($i;try @from @to @handler "java.lang.Exception") - ($i;label @from) + (-> $.Inst $.Inst) + (<| $i.with-label (function [@from]) + $i.with-label (function [@to]) + $i.with-label (function [@handler]) + (|>> ($i.try @from @to @handler "java.lang.Exception") + ($i.label @from) unsafeI someI - $i;ARETURN - ($i;label @to) - ($i;label @handler) + $i.ARETURN + ($i.label @to) + ($i.label @handler) noneI - $i;ARETURN))) + $i.ARETURN))) (def: #export string-concatI - $;Inst - ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) + $.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) (def: #export (apply-signature arity) - (-> ls;Arity $;Method) - ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + (-> ls.Arity $.Method) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) (def: adt-methods - $;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) - 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 + $.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) + 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 + 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 + $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 + 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 + ($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) + 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)) - (|>. ($i;int 3) - ($i;array $Object) + (|>> ($i.int 3) + ($i.array $Object) store-tagI store-flagI store-valueI - $i;ARETURN))))) + $i.ARETURN))))) (def: #export force-textI - $;Inst - ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) + $.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 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 hostL;runtime-class "_toUnsignedBigInteger" upcast-method false) - downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] - (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method - (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) - discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where))) - prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR + $.Def + (let [compare-nat-method ($t.method (list $t.long $t.long) (#.Some $t.int) (list)) + 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 hostL.runtime-class "_toUnsignedBigInteger" upcast-method false) + downcastI ($i.INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t.method (list) (#.Some $t.long) (list)) false)] + (|>> ($d.method #$.Public $.staticM "_toUnsignedBigInteger" upcast-method + (let [upcastI ($i.INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) + discernI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGE @where))) + prepare-upperI (|>> ($i.LLOAD +0) ($i.int 32) $i.LUSHR upcastI - ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false)) - prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL - ($i;int 32) $i;LUSHR + ($i.int 32) ($i.INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t.method (list $t.int) (#.Some $BigInteger) (list)) false)) + prepare-lowerI (|>> ($i.LLOAD +0) ($i.int 32) $i.LSHL + ($i.int 32) $i.LUSHR upcastI)] - (<| $i;with-label (function [@simple]) - (|>. (discernI @simple) + (<| $i.with-label (function [@simple]) + (|>> (discernI @simple) ## else prepare-upperI prepare-lowerI - ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false) - $i;ARETURN + ($i.INVOKEVIRTUAL "java.math.BigInteger" "add" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false) + $i.ARETURN ## then - ($i;label @simple) - ($i;LLOAD +0) + ($i.label @simple) + ($i.LLOAD +0) upcastI - $i;ARETURN)))) - ($d;method #$;Public $;staticM "compare_nat" compare-nat-method - (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)] - (|>. ($i;LLOAD +0) shiftI - ($i;LLOAD +2) shiftI - $i;LCMP - $i;IRETURN))) - ($d;method #$;Public $;staticM "div_nat" div-method - (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where))) - is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where))) - small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN) - big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] - (<| $i;with-label (function [@is-zero]) - $i;with-label (function [@param-is-large]) - $i;with-label (function [@subject-is-small]) - (|>. (is-param-largeI @param-is-large) + $i.ARETURN)))) + ($d.method #$.Public $.staticM "compare_nat" compare-nat-method + (let [shiftI (|>> ($i.GETSTATIC "java.lang.Long" "MIN_VALUE" $t.long) $i.LADD)] + (|>> ($i.LLOAD +0) shiftI + ($i.LLOAD +2) shiftI + $i.LCMP + $i.IRETURN))) + ($d.method #$.Public $.staticM "div_nat" div-method + (let [is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLT @where))) + is-subject-smallI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGT @where))) + small-division (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LDIV $i.LRETURN) + big-divisionI ($i.INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] + (<| $i.with-label (function [@is-zero]) + $i.with-label (function [@param-is-large]) + $i.with-label (function [@subject-is-small]) + (|>> (is-param-largeI @param-is-large) ## Param is not too large (is-subject-smallI @subject-is-small) ## Param is small, but subject is large - ($i;LLOAD +0) upcastI - ($i;LLOAD +2) upcastI - big-divisionI downcastI $i;LRETURN + ($i.LLOAD +0) upcastI + ($i.LLOAD +2) upcastI + big-divisionI downcastI $i.LRETURN ## Both param and subject are small, ## and can thus be divided normally. - ($i;label @subject-is-small) + ($i.label @subject-is-small) small-division ## Param is too large. Cannot simply divide. ## Depending on the result of the ## comparison, a result will be determined. - ($i;label @param-is-large) - ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero) + ($i.label @param-is-large) + ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @is-zero) ## Greater-than or equals - ($i;long 1) $i;LRETURN + ($i.long 1) $i.LRETURN ## Less than - ($i;label @is-zero) - ($i;long 0) $i;LRETURN)))) - ($d;method #$;Public $;staticM "rem_nat" div-method - (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where))) - is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where))) - small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN) - big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] - (<| $i;with-label (function [@large-number]) - $i;with-label (function [@subject-is-smaller-than-param]) - (|>. (is-subject-largeI @large-number) + ($i.label @is-zero) + ($i.long 0) $i.LRETURN)))) + ($d.method #$.Public $.staticM "rem_nat" div-method + (let [is-subject-largeI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFLE @where))) + is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLE @where))) + small-remainderI (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LREM $i.LRETURN) + big-remainderI ($i.INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] + (<| $i.with-label (function [@large-number]) + $i.with-label (function [@subject-is-smaller-than-param]) + (|>> (is-subject-largeI @large-number) (is-param-largeI @large-number) small-remainderI - ($i;label @large-number) - ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param) + ($i.label @large-number) + ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @subject-is-smaller-than-param) - ($i;LLOAD +0) upcastI - ($i;LLOAD +2) upcastI - big-remainderI downcastI $i;LRETURN + ($i.LLOAD +0) upcastI + ($i.LLOAD +2) upcastI + big-remainderI downcastI $i.LRETURN - ($i;label @subject-is-smaller-than-param) - ($i;LLOAD +0) - $i;LRETURN)))) + ($i.label @subject-is-smaller-than-param) + ($i.LLOAD +0) + $i.LRETURN)))) ))) -(def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0))) +(def: frac-shiftI $.Inst ($i.double (math.pow 32.0 2.0))) (def: frac-methods - $;Def - (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) + $.Def + (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) (try-methodI - (|>. ($i;ALOAD +0) - ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false) - ($i;wrap #$;Double)))) - ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list)) - (let [swap2 (|>. $i;DUP2_X2 $i;POP2) - drop-excessI (|>. ($i;double 1.0) $i;DREM) - shiftI (|>. frac-shiftI $i;DMUL)] - (|>. ($i;DLOAD +0) + (|>> ($i.ALOAD +0) + ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) + ($i.wrap #$.Double)))) + ($d.method #$.Public $.staticM "frac_to_deg" ($t.method (list $t.double) (#.Some $t.long) (list)) + (let [swap2 (|>> $i.DUP2_X2 $i.POP2) + drop-excessI (|>> ($i.double 1.0) $i.DREM) + shiftI (|>> frac-shiftI $i.DMUL)] + (|>> ($i.DLOAD +0) ## Get upper half drop-excessI shiftI ## Make a copy, so the lower half can be extracted - $i;DUP2 + $i.DUP2 ## Get lower half drop-excessI shiftI ## Turn it into a deg - $i;D2L + $i.D2L ## Turn the upper half into deg too swap2 - $i;D2L + $i.D2L ## Combine both pieces - $i;LADD + $i.LADD ## FINISH - $i;LRETURN + $i.LRETURN ))) )) (def: deg-bits Nat +64) -(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) -(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list))) +(def: deg-method $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) +(def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list))) (def: deg-methods - $;Def + $.Def (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. - low-half (|>. ($i;int -1) $i;I2L $i;LAND) - high-half (|>. ($i;int 32) $i;LUSHR)] - (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method + low-half (|>> ($i.int -1) $i.I2L $i.LAND) + high-half (|>> ($i.int 32) $i.LUSHR)] + (|>> ($d.method #$.Public $.staticM "mul_deg" deg-method ## Based on: http://stackoverflow.com/a/31629280/6823464 - (let [shift-downI (|>. ($i;int 32) $i;LUSHR) - low-leftI (|>. ($i;LLOAD +0) low-half) - high-leftI (|>. ($i;LLOAD +0) high-half) - low-rightI (|>. ($i;LLOAD +2) low-half) - high-rightI (|>. ($i;LLOAD +2) high-half) - bottomI (|>. low-leftI low-rightI $i;LMUL) - middleLI (|>. high-leftI low-rightI $i;LMUL) - middleRI (|>. low-leftI high-rightI $i;LMUL) - middleI (|>. middleLI middleRI $i;LADD) - topI (|>. high-leftI high-rightI $i;LMUL)] - (|>. bottomI shift-downI - middleI $i;LADD shift-downI - topI $i;LADD - $i;LRETURN))) - ($d;method #$;Public $;staticM "count_leading_zeros" clz-method - (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where))) - shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR)) - decI (|>. ($i;int 1) $i;ISUB)] - (<| $i;with-label (function [@start]) - $i;with-label (function [@done]) - (|>. ($i;int 64) - ($i;label @start) - ($i;LLOAD +0) (when-zeroI @done) - ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0) + (let [shift-downI (|>> ($i.int 32) $i.LUSHR) + low-leftI (|>> ($i.LLOAD +0) low-half) + high-leftI (|>> ($i.LLOAD +0) high-half) + low-rightI (|>> ($i.LLOAD +2) low-half) + high-rightI (|>> ($i.LLOAD +2) high-half) + bottomI (|>> low-leftI low-rightI $i.LMUL) + middleLI (|>> high-leftI low-rightI $i.LMUL) + middleRI (|>> low-leftI high-rightI $i.LMUL) + middleI (|>> middleLI middleRI $i.LADD) + topI (|>> high-leftI high-rightI $i.LMUL)] + (|>> bottomI shift-downI + middleI $i.LADD shift-downI + topI $i.LADD + $i.LRETURN))) + ($d.method #$.Public $.staticM "count_leading_zeros" clz-method + (let [when-zeroI (function [@where] (|>> ($i.long 0) $i.LCMP ($i.IFEQ @where))) + shift-rightI (function [amount] (|>> ($i.int amount) $i.LUSHR)) + decI (|>> ($i.int 1) $i.ISUB)] + (<| $i.with-label (function [@start]) + $i.with-label (function [@done]) + (|>> ($i.int 64) + ($i.label @start) + ($i.LLOAD +0) (when-zeroI @done) + ($i.LLOAD +0) (shift-rightI 1) ($i.LSTORE +0) decI - ($i;GOTO @start) - ($i;label @done) - $i;IRETURN)))) - ($d;method #$;Public $;staticM "div_deg" deg-method - (<| $i;with-label (function [@same]) - (let [subjectI ($i;LLOAD +0) - paramI ($i;LLOAD +2) - equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) - count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false) - calc-max-shiftI (|>. subjectI count-leading-zerosI + ($i.GOTO @start) + ($i.label @done) + $i.IRETURN)))) + ($d.method #$.Public $.staticM "div_deg" deg-method + (<| $i.with-label (function [@same]) + (let [subjectI ($i.LLOAD +0) + paramI ($i.LLOAD +2) + equal?I (function [@where] (|>> $i.LCMP ($i.IFEQ @where))) + 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) - ($i;ISTORE +4)) - shiftI (|>. ($i;ILOAD +4) $i;LSHL) - imprecise-divisionI (|>. subjectI shiftI + ($i.INVOKESTATIC "java.lang.Math" "min" ($t.method (list $t.int $t.int) (#.Some $t.int) (list)) false) + ($i.ISTORE +4)) + shiftI (|>> ($i.ILOAD +4) $i.LSHL) + imprecise-divisionI (|>> subjectI shiftI paramI shiftI high-half - $i;LDIV) - scale-downI (|>. ($i;int 32) $i;LSHL)] - (|>. subjectI paramI + $i.LDIV) + scale-downI (|>> ($i.int 32) $i.LSHL)] + (|>> subjectI paramI (equal?I @same) ## Based on: http://stackoverflow.com/a/8510587/6823464 ## Shifting the operands as much as possible can help @@ -373,255 +349,255 @@ calc-max-shiftI imprecise-divisionI scale-downI - $i;LRETURN - ($i;label @same) - ($i;long -1) ## ~= 1.0 Degrees - $i;LRETURN)))) - ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) - (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D) - lowI (|>. ($i;LLOAD +0) low-half $i;L2D) - scaleI (|>. frac-shiftI $i;DDIV)] - (|>. highI scaleI + $i.LRETURN + ($i.label @same) + ($i.long -1) ## ~= 1.0 Degrees + $i.LRETURN)))) + ($d.method #$.Public $.staticM "deg_to_frac" ($t.method (list $t.long) (#.Some $t.double) (list)) + (let [highI (|>> ($i.LLOAD +0) high-half $i.L2D) + lowI (|>> ($i.LLOAD +0) low-half $i.L2D) + scaleI (|>> frac-shiftI $i.DDIV)] + (|>> highI scaleI lowI scaleI scaleI - $i;DADD - $i;DRETURN))) + $i.DADD + $i.DRETURN))) ))) (def: text-methods - $;Def - (|>. ($d;method #$;Public $;staticM "text_clip" ($t;method (list $String $t;int $t;int) (#;Some $Variant) (list)) + $.Def + (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) (try-methodI - (|>. ($i;ALOAD +0) - ($i;ILOAD +1) - ($i;ILOAD +2) - ($i;INVOKEVIRTUAL "java.lang.String" "substring" ($t;method (list $t;int $t;int) (#;Some $String) (list)) false)))) - ($d;method #$;Public $;staticM "text_char" ($t;method (list $String $t;int) (#;Some $Variant) (list)) + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.ILOAD +2) + ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false)))) + ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) (try-methodI - (|>. ($i;ALOAD +0) - ($i;ILOAD +1) - ($i;INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t;method (list $t;int) (#;Some $t;int) (list)) false) - $i;I2L - ($i;wrap #$;Long)))) + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false) + $i.I2L + ($i.wrap #$.Long)))) )) (def: pm-methods - $;Def - (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH) - tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD) - expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD) - tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))] - (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list)) - (|>. ($i;NEW "java.lang.IllegalStateException") - $i;DUP - ($i;string "Invalid expression for pattern-matching.") - ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) - $i;ATHROW)) - ($d;method #$;Public $;staticM "apply_fail" ($t;method (list) #;None (list)) - (|>. ($i;NEW "java.lang.IllegalStateException") - $i;DUP - ($i;string "Error while applying function.") - ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) - $i;ATHROW)) - ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list)) - (|>. ($i;int 2) - ($i;ANEWARRAY "java.lang.Object") - $i;DUP - ($i;int 0) - ($i;ALOAD +0) - $i;AASTORE - $i;DUP - ($i;int 1) - ($i;ALOAD +1) - $i;AASTORE - $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list)) - (|>. ($i;ALOAD +0) - ($i;int 0) - $i;AALOAD - ($i;CHECKCAST ($t;descriptor $Stack)) - $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list)) - (|>. ($i;ALOAD +0) - ($i;int 1) - $i;AALOAD - $i;ARETURN)) - ($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]) - $i;with-label (function [@further]) - $i;with-label (function [@shorten]) - $i;with-label (function [@wrong]) - (let [variant-partI (: (-> Nat $;Inst) + $.Def + (let [tuple-sizeI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH) + tuple-elemI (|>> ($i.ALOAD +0) ($i.ILOAD +1) $i.AALOAD) + expected-last-sizeI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD) + tuple-tailI (|>> ($i.ALOAD +0) tuple-sizeI ($i.int 1) $i.ISUB $i.AALOAD ($i.CHECKCAST ($t.descriptor $Tuple)))] + (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) + (|>> ($i.NEW "java.lang.IllegalStateException") + $i.DUP + ($i.string "Invalid expression for pattern-matching.") + ($i.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) false) + $i.ATHROW)) + ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) + (|>> ($i.NEW "java.lang.IllegalStateException") + $i.DUP + ($i.string "Error while applying function.") + ($i.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) false) + $i.ATHROW)) + ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) + (|>> ($i.int 2) + ($i.ANEWARRAY "java.lang.Object") + $i.DUP + ($i.int 0) + ($i.ALOAD +0) + $i.AASTORE + $i.DUP + ($i.int 1) + ($i.ALOAD +1) + $i.AASTORE + $i.ARETURN)) + ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) + (|>> ($i.ALOAD +0) + ($i.int 0) + $i.AALOAD + ($i.CHECKCAST ($t.descriptor $Stack)) + $i.ARETURN)) + ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) + (|>> ($i.ALOAD +0) + ($i.int 1) + $i.AALOAD + $i.ARETURN)) + ($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]) + $i.with-label (function [@further]) + $i.with-label (function [@shorten]) + $i.with-label (function [@wrong]) + (let [variant-partI (: (-> Nat $.Inst) (function [idx] - (|>. ($i;int (nat-to-int idx)) $i;AALOAD))) - tagI (: $;Inst - (|>. (variant-partI +0) ($i;unwrap #$;Int))) + (|>> ($i.int (nat-to-int idx)) $i.AALOAD))) + tagI (: $.Inst + (|>> (variant-partI +0) ($i.unwrap #$.Int))) flagI (variant-partI +1) datumI (variant-partI +2) - shortenI (|>. ($i;ALOAD +0) tagI ## Get tag - ($i;ILOAD +1) $i;ISUB ## Shorten tag - ($i;ALOAD +0) flagI ## Get flag - ($i;ALOAD +0) datumI ## Get value + shortenI (|>> ($i.ALOAD +0) tagI ## Get tag + ($i.ILOAD +1) $i.ISUB ## Shorten tag + ($i.ALOAD +0) flagI ## Get flag + ($i.ALOAD +0) datumI ## Get value variantI ## Build sum - $i;ARETURN) - update-tagI (|>. $i;ISUB ($i;ISTORE +1)) - update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) - failureI (|>. $i;NULL $i;ARETURN) - return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)]) - (|>. ($i;label @begin) - ($i;ILOAD +1) ## tag - ($i;ALOAD +0) tagI ## tag, sumT - $i;DUP2 ($i;IF_ICMPEQ @then) - $i;DUP2 ($i;IF_ICMPGT @further) - $i;DUP2 ($i;IF_ICMPLT @shorten) - ## $i;POP2 + $i.ARETURN) + update-tagI (|>> $i.ISUB ($i.ISTORE +1)) + update-variantI (|>> ($i.ALOAD +0) datumI ($i.CHECKCAST ($t.descriptor $Variant)) ($i.ASTORE +0)) + failureI (|>> $i.NULL $i.ARETURN) + return-datumI (|>> ($i.ALOAD +0) datumI $i.ARETURN)]) + (|>> ($i.label @begin) + ($i.ILOAD +1) ## tag + ($i.ALOAD +0) tagI ## tag, sumT + $i.DUP2 ($i.IF_ICMPEQ @then) + $i.DUP2 ($i.IF_ICMPGT @further) + $i.DUP2 ($i.IF_ICMPLT @shorten) + ## $i.POP2 failureI - ($i;label @then) ## tag, sumT - ($i;ALOAD +2) ## tag, sumT, wants-last? - ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? - ($i;IF_ACMPEQ @just-return) ## tag, sumT - ($i;label @further) ## tag, sumT - ($i;ALOAD +0) flagI ## tag, sumT, last? - ($i;IFNULL @wrong) ## tag, sumT + ($i.label @then) ## tag, sumT + ($i.ALOAD +2) ## tag, sumT, wants-last? + ($i.ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? + ($i.IF_ACMPEQ @just-return) ## tag, sumT + ($i.label @further) ## tag, sumT + ($i.ALOAD +0) flagI ## tag, sumT, last? + ($i.IFNULL @wrong) ## tag, sumT update-tagI update-variantI - ($i;GOTO @begin) - ($i;label @just-return) ## tag, sumT - ## $i;POP2 + ($i.GOTO @begin) + ($i.label @just-return) ## tag, sumT + ## $i.POP2 return-datumI - ($i;label @shorten) ## tag, sumT - ($i;ALOAD +2) ($i;IFNULL @wrong) - ## $i;POP2 + ($i.label @shorten) ## tag, sumT + ($i.ALOAD +2) ($i.IFNULL @wrong) + ## $i.POP2 shortenI - ($i;label @wrong) ## tag, sumT - ## $i;POP2 + ($i.label @wrong) ## tag, sumT + ## $i.POP2 failureI))) - ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) - (<| $i;with-label (function [@begin]) - $i;with-label (function [@not-recursive]) - (let [updated-idxI (|>. $i;SWAP $i;ISUB)]) - (|>. ($i;label @begin) + ($d.method #$.Public $.staticM "pm_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) + (<| $i.with-label (function [@begin]) + $i.with-label (function [@not-recursive]) + (let [updated-idxI (|>> $i.SWAP $i.ISUB)]) + (|>> ($i.label @begin) tuple-sizeI expected-last-sizeI - $i;DUP2 ($i;IF_ICMPGT @not-recursive) + $i.DUP2 ($i.IF_ICMPGT @not-recursive) ## Recursive - updated-idxI ($i;ISTORE +1) - tuple-tailI ($i;ASTORE +0) - ($i;GOTO @begin) - ($i;label @not-recursive) - ## $i;POP2 + updated-idxI ($i.ISTORE +1) + tuple-tailI ($i.ASTORE +0) + ($i.GOTO @begin) + ($i.label @not-recursive) + ## $i.POP2 tuple-elemI - $i;ARETURN))) - ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) - (<| $i;with-label (function [@begin]) - $i;with-label (function [@tail]) - $i;with-label (function [@slice]) - (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB) - sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI - ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))]) - (|>. ($i;label @begin) + $i.ARETURN))) + ($d.method #$.Public $.staticM "pm_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) + (<| $i.with-label (function [@begin]) + $i.with-label (function [@tail]) + $i.with-label (function [@slice]) + (let [updated-idxI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD tuple-sizeI $i.ISUB) + sliceI (|>> ($i.ALOAD +0) ($i.ILOAD +1) tuple-sizeI + ($i.INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t.method (list $Object-Array $t.int $t.int) (#.Some $Object-Array) (list)) false))]) + (|>> ($i.label @begin) tuple-sizeI expected-last-sizeI - $i;DUP2 ($i;IF_ICMPEQ @tail) - ($i;IF_ICMPGT @slice) + $i.DUP2 ($i.IF_ICMPEQ @tail) + ($i.IF_ICMPGT @slice) ## Must recurse - tuple-tailI ($i;ASTORE +0) - updated-idxI ($i;ISTORE +1) - ($i;GOTO @begin) - ($i;label @slice) + tuple-tailI ($i.ASTORE +0) + updated-idxI ($i.ISTORE +1) + ($i.GOTO @begin) + ($i.label @slice) sliceI - $i;ARETURN - ($i;label @tail) - ## $i;POP2 + $i.ARETURN + ($i.label @tail) + ## $i.POP2 tuple-elemI - $i;ARETURN))) + $i.ARETURN))) ))) (def: io-methods - $;Def - (let [string-writerI (|>. ($i;NEW "java.io.StringWriter") - $i;DUP - ($i;INVOKESPECIAL "java.io.StringWriter" "<init>" ($t;method (list) #;None (list)) false)) - print-writerI (|>. ($i;NEW "java.io.PrintWriter") - $i;SWAP - $i;DUP2 - $i;POP - $i;SWAP - ($i;boolean true) - ($i;INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false) + $.Def + (let [string-writerI (|>> ($i.NEW "java.io.StringWriter") + $i.DUP + ($i.INVOKESPECIAL "java.io.StringWriter" "<init>" ($t.method (list) #.None (list)) false)) + print-writerI (|>> ($i.NEW "java.io.PrintWriter") + $i.SWAP + $i.DUP2 + $i.POP + $i.SWAP + ($i.boolean true) + ($i.INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) false) )] - (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list)) - (<| $i;with-label (function [@from]) - $i;with-label (function [@to]) - $i;with-label (function [@handler]) - (|>. ($i;try @from @to @handler "java.lang.Throwable") - ($i;label @from) - ($i;ALOAD +0) - $i;NULL - ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) + (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) + (<| $i.with-label (function [@from]) + $i.with-label (function [@to]) + $i.with-label (function [@handler]) + (|>> ($i.try @from @to @handler "java.lang.Throwable") + ($i.label @from) + ($i.ALOAD +0) + $i.NULL + ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) rightI - $i;ARETURN - ($i;label @to) - ($i;label @handler) + $i.ARETURN + ($i.label @to) + ($i.label @handler) string-writerI ## TW - $i;DUP2 ## TWTW + $i.DUP2 ## TWTW print-writerI ## TWTP - ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW - ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS - $i;SWAP $i;POP leftI - $i;ARETURN))) + ($i.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) false) ## TW + ($i.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) false) ## TS + $i.SWAP $i.POP leftI + $i.ARETURN))) ))) (def: translate-runtime - (Meta commonT;Bytecode) - (do macro;Monad<Meta> + (Meta commonT.Bytecode) + (do macro.Monad<Meta> [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) - (|>. adt-methods + #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 text-methods pm-methods io-methods))] - _ (commonT;store-class hostL;runtime-class bytecode)] + _ (commonT.store-class hostL.runtime-class bytecode)] (wrap bytecode))) (def: translate-function - (Meta commonT;Bytecode) - (do macro;Monad<Meta> + (Meta commonT.Bytecode) + (do macro.Monad<Meta> [_ (wrap []) - #let [applyI (|> (list;n.range +2 num-apply-variants) + #let [applyI (|> (list.n/range +2 num-apply-variants) (list/map (function [arity] - ($d;method #$;Public $;noneM apply-method (apply-signature arity) - (let [preI (|> (list;n.range +0 (n.dec arity)) - (list/map $i;ALOAD) - $i;fuse)] - (|>. preI - ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false) - ($i;CHECKCAST hostL;function-class) - ($i;ALOAD arity) - ($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 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 hostL;function-class partials-field $t;int) - $i;RETURN)) + ($d.method #$.Public $.noneM apply-method (apply-signature arity) + (let [preI (|> (list.n/range +0 (n/dec arity)) + (list/map $i.ALOAD) + $i.fuse)] + (|>> preI + ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (n/dec arity)) false) + ($i.CHECKCAST hostL.function-class) + ($i.ALOAD arity) + ($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 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 hostL.function-class partials-field $t.int) + $i.RETURN)) applyI))] - _ (commonT;store-class hostL;function-class bytecode)] + _ (commonT.store-class hostL.function-class bytecode)] (wrap bytecode))) (def: #export translate - (Meta [commonT;Bytecode commonT;Bytecode]) - (do macro;Monad<Meta> + (Meta [commonT.Bytecode commonT.Bytecode]) + (do macro.Monad<Meta> [runtime-bc translate-runtime function-bc translate-function] (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux index df7e26741..a734adfed 100644 --- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -10,84 +10,81 @@ [macro] [host]) (luxc ["&" lang] - ["&;" io] + ["&." io] (lang (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) - ["&;" scope] - ["&;" module] - (translation [";T" eval] - [";T" common])))) + ["&." scope] + ["&." module] + (translation [".T" eval] + [".T" common])))) (exception: #export Invalid-Definition-Value) (exception: #export Cannot-Evaluate-Definition) -(host;import java.lang.Object - (toString [] String)) - -(host;import java.lang.reflect.Field +(host.import java/lang/reflect/Field (get [#? Object] #try #? Object)) -(host;import (java.lang.Class c) +(host.import (java/lang/Class c) (getField [String] #try Field)) (def: #export (translate-def def-name valueT valueI metaI metaV) - (-> Text Type $;Inst $;Inst Code (Meta Unit)) - (do macro;Monad<Meta> - [current-module macro;current-module-name + (-> Text Type $.Inst $.Inst Code (Meta Unit)) + (do macro.Monad<Meta> + [current-module macro.current-module-name #let [def-ident [current-module def-name]]] - (case (macro;get-symbol-ann (ident-for #;alias) metaV) - (#;Some real-def) + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) (do @ - [[realT realA realV] (macro;find-def real-def) - _ (&module;define def-ident [realT metaV realV])] + [[realT realA realV] (macro.find-def real-def) + _ (&module.define def-ident [realT metaV realV])] (wrap [])) _ (do @ - [#let [normal-name (format (&;normalize-name def-name) (%n (text/hash def-name))) + [#let [normal-name (format (&.normalize-name def-name) (%n (text/hash def-name))) bytecode-name (format current-module "/" normal-name) - class-name (format (text;replace-all "/" "." current-module) "." normal-name) - bytecode ($d;class #$;V1.6 - #$;Public $;finalC + class-name (format (text.replace-all "/" "." current-module) "." normal-name) + bytecode ($d.class #$.V1_6 + #$.Public $.finalC bytecode-name (list) ["java.lang.Object" (list)] (list) - (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object) - ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list)) - (|>. valueI - ($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object) - $i;RETURN))))] - _ (commonT;store-class class-name bytecode) - class (commonT;load-class class-name) + (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) commonT.value-field commonT.$Object) + ($d.method #$.Public $.staticM "<clinit>" ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC bytecode-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class class-name bytecode) + class (commonT.load-class class-name) valueV (: (Meta Top) - (case (do e;Monad<Error> - [field (Class.getField [commonT;value-field] class)] - (Field.get [#;None] field)) - (#e;Success #;None) - (&;throw Invalid-Definition-Value (%ident def-ident)) + (case (do e.Monad<Error> + [field (Class::getField [commonT.value-field] class)] + (Field::get [#.None] field)) + (#e.Success #.None) + (&.throw Invalid-Definition-Value (%ident def-ident)) - (#e;Success (#;Some valueV)) + (#e.Success (#.Some valueV)) (wrap valueV) - (#e;Error error) - (&;throw Cannot-Evaluate-Definition + (#e.Error error) + (&.throw Cannot-Evaluate-Definition (format "Definition: " (%ident def-ident) "\n" "Error:\n" error)))) - _ (&module;define def-ident [valueT metaV valueV]) - _ (if (macro;type? metaV) - (case (macro;declared-tags metaV) - #;Nil + _ (&module.define def-ident [valueT metaV valueV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil (wrap []) tags - (&module;declare-tags tags (macro;export? metaV) (:! Type valueV))) + (&module.declare-tags tags (macro.export? metaV) (:! Type valueV))) (wrap [])) #let [_ (log! (format "DEF " (%ident def-ident)))]] - (commonT;record-artifact (format bytecode-name ".class") bytecode))))) + (commonT.record-artifact (format bytecode-name ".class") bytecode))))) (def: #export (translate-program program-args programI) - (-> Text $;Inst (Meta Unit)) - (&;fail "\"lux program\" is unimplemented.")) + (-> Text $.Inst (Meta Unit)) + (&.fail "\"lux program\" is unimplemented.")) diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux index ddb48a31e..9a78be78e 100644 --- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -7,55 +7,55 @@ [macro] [host #+ do-to]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])))) + (translation [".T" common])))) (exception: #export Not-A-Tuple) -(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: #export (translate-tuple translate members) - (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) - (do macro;Monad<Meta> - [#let [size (list;size members)] - _ (&;assert Not-A-Tuple (%code (` [(~@ members)])) - (n.>= +2 size)) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) (Meta $.Inst)) + (do macro.Monad<Meta> + [#let [size (list.size members)] + _ (&.assert Not-A-Tuple (%code (` [(~@ members)])) + (n/>= +2 size)) membersI (|> members - list;enumerate - (monad;map @ (function [[idx member]] + list.enumerate + (monad.map @ (function [[idx member]] (do @ [memberI (translate member)] - (wrap (|>. $i;DUP - ($i;int (nat-to-int idx)) + (wrap (|>> $i.DUP + ($i.int (nat-to-int idx)) memberI - $i;AASTORE))))) - (:: @ map $i;fuse))] - (wrap (|>. ($i;int (nat-to-int size)) - ($i;array $Object) + $i.AASTORE))))) + (:: @ map $i.fuse))] + (wrap (|>> ($i.int (nat-to-int size)) + ($i.array $Object) membersI)))) (def: (flagI tail?) - (-> Bool $;Inst) + (-> Bool $.Inst) (if tail? - ($i;string "") - $i;NULL)) + ($i.string "") + $i.NULL)) (def: #export (translate-variant translate tag tail? member) - (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) - (do macro;Monad<Meta> + (-> (-> ls.Synthesis (Meta $.Inst)) Nat Bool ls.Synthesis (Meta $.Inst)) + (do macro.Monad<Meta> [memberI (translate member)] - (wrap (|>. ($i;int (nat-to-int tag)) + (wrap (|>> ($i.int (nat-to-int tag)) (flagI tail?) memberI - ($i;INVOKESTATIC hostL;runtime-class + ($i.INVOKESTATIC hostL.runtime-class "variant_make" - ($t;method (list $t;int $Object $Object) - (#;Some ($t;array +1 $Object)) + ($t.method (list $t.int $Object $Object) + (#.Some ($t.array +1 $Object)) (list)) false))))) diff --git a/new-luxc/source/luxc/lang/variable.lux b/new-luxc/source/luxc/lang/variable.lux index f766ffdcf..55f6ac877 100644 --- a/new-luxc/source/luxc/lang/variable.lux +++ b/new-luxc/source/luxc/lang/variable.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (data (coll [list "list/" Functor<List>])))) @@ -7,7 +7,7 @@ (def: #export (captured register) (-> Register Variable) - (|> register n.inc nat-to-int (i.* -1))) + (|> register n/inc nat-to-int (i/* -1))) (def: #export (local register) (-> Register Variable) @@ -19,29 +19,29 @@ (def: #export (captured-register variable) (-> Variable Register) - (|> variable (i.* -1) int-to-nat n.dec)) + (|> variable (i/* -1) int-to-nat n/dec)) (do-template [<name> <comp>] [(def: #export (<name> var) (-> Variable Bool) (<comp> 0 var))] - [self? i.=] - [local? i.>] - [captured? i.<] + [self? i/=] + [local? i/>] + [captured? i/<] ) (def: #export (from-ref ref) (-> Ref Variable) (case ref - (#;Local register) + (#.Local register) (local register) - (#;Captured register) + (#.Captured register) (captured register))) (def: #export (environment scope) (-> Scope (List Variable)) (|> scope - (get@ [#;captured #;mappings]) + (get@ [#.captured #.mappings]) (list/map (function [[_ [_ ref]]] (from-ref ref))))) diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux index 2ed106545..8ac220d0f 100644 --- a/new-luxc/source/luxc/module/descriptor/annotation.lux +++ b/new-luxc/source/luxc/module/descriptor/annotation.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control codec monad) @@ -9,12 +9,12 @@ error (coll [list "L/" Functor<List>]))) ["&" ../common] - [luxc ["&;" parser]]) + [luxc ["&." parser]]) (def: dummy-cursor Cursor ["" +1 +0]) (do-template [<name> <code>] - [(def: <name> &;Signal <code>)] + [(def: <name> &.Signal <code>)] [ident-signal "@"] [bool-signal "B"] @@ -30,14 +30,14 @@ (def: (encode-ident [module name]) (-> Ident Text) (format ident-signal - module &;ident-separator name - &;stop-signal)) + module &.ident-separator name + &.stop-signal)) (def: (encode-text value) (-> Text Text) (format text-signal (%t value) - &;stop-signal)) + &.stop-signal)) (def: (encode-ann-value value) (-> Ann-Value Text) @@ -46,33 +46,33 @@ (<tag> value) (format <signal> (<encoder> value) - &;stop-signal)) - ([#;BoolA bool-signal %b] - [#;NatA nat-signal %n] - [#;IntA int-signal %i] - [#;DegA deg-signal %d] - [#;FracA frac-signal %r] - [#;TextA text-signal %t] - [#;IdentA ident-signal %ident] - [#;ListA list-signal (&;encode-list encode-ann-value)] - [#;DictA dict-signal (&;encode-list (function [[k v]] + &.stop-signal)) + ([#.BoolA bool-signal %b] + [#.NatA nat-signal %n] + [#.IntA int-signal %i] + [#.DegA deg-signal %d] + [#.FracA frac-signal %r] + [#.TextA text-signal %t] + [#.IdentA ident-signal %ident] + [#.ListA list-signal (&.encode-list encode-ann-value)] + [#.DictA dict-signal (&.encode-list (function [[k v]] (format (encode-text k) (encode-ann-value v))))]))) (def: ann-value-decoder - (l;Lexer Ann-Value) + (l.Lexer Ann-Value) (with-expansions [<simple> (do-template [<tag> <lexer> <signal>] - [(do l;Monad<Lexer> + [(do l.Monad<Lexer> [])])] - ($_ l;either + ($_ l.either <simple> - (|> ... (l;after (l;text bool-signal))) + (|> ... (l.after (l.text bool-signal))) ))) (def: encode-anns (-> Anns Text) - (&;encode-list (function [[ident value]] + (&.encode-list (function [[ident value]] (format (encode-ident ident) (encode-ann-value value))))) diff --git a/new-luxc/source/luxc/module/descriptor/common.lux b/new-luxc/source/luxc/module/descriptor/common.lux index aac438a6f..b123fe852 100644 --- a/new-luxc/source/luxc/module/descriptor/common.lux +++ b/new-luxc/source/luxc/module/descriptor/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (data [text] (text format @@ -18,20 +18,20 @@ (do-template [<name> <code>] [(def: #export <name> Signal <code>)] - [ident-separator ";"] + [ident-separator "."] ) (def: #export (encode-list encode-elem types) (All [a] (-> (-> a Text) (List a) Text)) (format (|> (L/map encode-elem types) - (text;join-with cons-signal)) + (text.join-with cons-signal)) nil-signal)) (def: #export (decode-list decode-elem) - (All [a] (-> (l;Lexer a) (l;Lexer (List a)))) - (l;alt (<| (l;after (l;text nil-signal)) + (All [a] (-> (l.Lexer a) (l.Lexer (List a)))) + (l.alt (<| (l.after (l.text nil-signal)) (l/wrap [])) - (<| (l;seq decode-elem) - (l;after (l;text cons-signal)) + (<| (l.seq decode-elem) + (l.after (l.text cons-signal)) (decode-list decode-elem)))) diff --git a/new-luxc/source/luxc/module/descriptor/type.lux b/new-luxc/source/luxc/module/descriptor/type.lux index 58e29c39e..d72229832 100644 --- a/new-luxc/source/luxc/module/descriptor/type.lux +++ b/new-luxc/source/luxc/module/descriptor/type.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control codec monad) @@ -12,7 +12,7 @@ ["&" ../common]) (do-template [<name> <code>] - [(def: <name> &;Signal <code>)] + [(def: <name> &.Signal <code>)] [type-signal "T"] [primitive-signal "^"] @@ -36,109 +36,109 @@ (type/= Type type)) type-signal (case type - (#;Primitive name params) - (format primitive-signal name &;stop-signal (&;encode-list encode-type params)) + (#.Primitive name params) + (format primitive-signal name &.stop-signal (&.encode-list encode-type params)) - #;Void + #.Void void-signal - #;Unit + #.Unit unit-signal (^template [<tag> <prefix>] (<tag> left right) (format <prefix> (encode-type left) (encode-type right))) - ([#;Product product-signal] - [#;Sum sum-signal] - [#;Function function-signal] - [#;App application-signal]) + ([#.Product product-signal] + [#.Sum sum-signal] + [#.Function function-signal] + [#.App application-signal]) (^template [<tag> <prefix>] (<tag> env body) - (format <prefix> (&;encode-list encode-type env) (encode-type body))) - ([#;UnivQ uq-signal] - [#;ExQ eq-signal]) + (format <prefix> (&.encode-list encode-type env) (encode-type body))) + ([#.UnivQ uq-signal] + [#.ExQ eq-signal]) (^template [<tag> <prefix>] (<tag> idx) - (format <prefix> (%i (nat-to-int idx)) &;stop-signal)) - ([#;Bound bound-signal] - [#;Ex ex-signal] - [#;Var var-signal]) + (format <prefix> (%i (nat-to-int idx)) &.stop-signal)) + ([#.Bound bound-signal] + [#.Ex ex-signal] + [#.Var var-signal]) - (#;Named [module name] type*) - (format named-signal module &;ident-separator name &;stop-signal (encode-type type*)) + (#.Named [module name] type*) + (format named-signal module &.ident-separator name &.stop-signal (encode-type type*)) ))) (def: type-decoder - (l;Lexer Type) - (l;rec + (l.Lexer Type) + (l.rec (function [type-decoder] (with-expansions [<simple> (do-template [<type> <signal>] - [(|> (l/wrap <type>) (l;after (l;text <signal>)))] + [(|> (l/wrap <type>) (l.after (l.text <signal>)))] [Type type-signal] - [#;Void void-signal] - [#;Unit unit-signal]) + [#.Void void-signal] + [#.Unit unit-signal]) <combinators> (do-template [<tag> <prefix>] - [(do l;Monad<Lexer> - [_ (l;text <prefix>) + [(do l.Monad<Lexer> + [_ (l.text <prefix>) left type-decoder right type-decoder] (wrap (<tag> left right)))] - [#;Product product-signal] - [#;Sum sum-signal] - [#;Function function-signal] - [#;App application-signal]) + [#.Product product-signal] + [#.Sum sum-signal] + [#.Function function-signal] + [#.App application-signal]) <abstractions> (do-template [<tag> <prefix>] - [(do l;Monad<Lexer> - [_ (l;text <prefix>) - env (&;decode-list type-decoder) + [(do l.Monad<Lexer> + [_ (l.text <prefix>) + env (&.decode-list type-decoder) body type-decoder] (wrap (<tag> env body)))] - [#;UnivQ uq-signal] - [#;ExQ eq-signal]) + [#.UnivQ uq-signal] + [#.ExQ eq-signal]) <wildcards> (do-template [<tag> <prefix>] - [(do l;Monad<Lexer> - [_ (l;text <prefix>) - id (l;codec number;Codec<Text,Int> - (l;some' l;digit)) - _ (l;text &;stop-signal)] + [(do l.Monad<Lexer> + [_ (l.text <prefix>) + id (l.codec number.Codec<Text,Int> + (l.some' l.digit)) + _ (l.text &.stop-signal)] (wrap (<tag> (int-to-nat id))))] - [#;Bound bound-signal] - [#;Ex ex-signal] - [#;Var var-signal])] - ($_ l;either - (do l;Monad<Lexer> - [_ (l;text primitive-signal) - name (l;many' (l;none-of &;stop-signal)) - _ (l;text &;stop-signal) - params (&;decode-list type-decoder)] - (wrap (#;Primitive name params))) + [#.Bound bound-signal] + [#.Ex ex-signal] + [#.Var var-signal])] + ($_ l.either + (do l.Monad<Lexer> + [_ (l.text primitive-signal) + name (l.many' (l.none-of &.stop-signal)) + _ (l.text &.stop-signal) + params (&.decode-list type-decoder)] + (wrap (#.Primitive name params))) <simple> <combinators> <abstractions> <wildcards> - (do l;Monad<Lexer> - [_ (l;text named-signal) - module (l;some' (l;none-of &;ident-separator)) - _ (l;text &;ident-separator) - name (l;many' (l;none-of &;stop-signal)) - _ (l;text &;stop-signal) + (do l.Monad<Lexer> + [_ (l.text named-signal) + module (l.some' (l.none-of &.ident-separator)) + _ (l.text &.ident-separator) + name (l.many' (l.none-of &.stop-signal)) + _ (l.text &.stop-signal) unnamed type-decoder] - (wrap (#;Named [module name] unnamed))) + (wrap (#.Named [module name] unnamed))) ))))) (def: (decode-type input) - (-> Text (e;Error Type)) + (-> Text (e.Error Type)) (|> type-decoder - (l;before l;end) - (l;run input))) + (l.before l.end) + (l.run input))) (struct: #export _ (Codec Text Type) (def: encode encode-type) diff --git a/new-luxc/source/luxc/repl.lux b/new-luxc/source/luxc/repl.lux index 5b957269f..15f343a7d 100644 --- a/new-luxc/source/luxc/repl.lux +++ b/new-luxc/source/luxc/repl.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -29,44 +29,44 @@ (world [file #+ File] [console #+ Console])) (luxc [lang] - (lang [";L" module] - [";L" scope] - [";L" host] - [";L" translation] - [";L" eval] - (translation [";T" runtime])))) + (lang [".L" module] + [".L" scope] + [".L" host] + [".L" translation] + [".L" eval] + (translation [".T" runtime])))) (exception: #export REPL-Initialization-Failed) (exception: #export REPL-Error) (def: repl-module "<REPL>") -(def: no-aliases Aliases (dict;new text;Hash<Text>)) +(def: no-aliases Aliases (dict.new text.Hash<Text>)) (def: (initialize source-dirs target-dir console) (-> (List File) File Console (Task Compiler)) - (do promise;Monad<Promise> - [output (promise;future - (do io;Monad<IO> - [host hostL;init-host] - (case (macro;run' (translationL;init-compiler host) - (moduleL;with-module +0 repl-module - runtimeT;translate)) - (#e;Success [compiler _]) - (translationL;translate-module source-dirs target-dir translationL;prelude compiler) - - (#e;Error error) - (wrap (#e;Error error)))))] + (do promise.Monad<Promise> + [output (promise.future + (do io.Monad<IO> + [host hostL.init-host] + (case (macro.run' (translationL.init-compiler host) + (moduleL.with-module +0 repl-module + runtimeT.translate)) + (#e.Success [compiler _]) + (translationL.translate-module source-dirs target-dir translationL.prelude compiler) + + (#e.Error error) + (wrap (#e.Error error)))))] (case output - (#e;Success compiler) - (do task;Monad<Task> - [_ (console;write (format "\nWelcome to the REPL!\n" + (#e.Success compiler) + (do task.Monad<Task> + [_ (console.write (format "\nWelcome to the REPL!\n" "Type \"exit\" to leave.\n\n") console)] (wrap compiler)) - (#e;Error message) - (task;throw REPL-Initialization-Failed message)))) + (#e.Error message) + (task.throw REPL-Initialization-Failed message)))) (def: (add-line line [where offset input]) (-> Text Source Source) @@ -76,35 +76,35 @@ (def: (represent-together representations values) (-> (List Representation) (List Top) (List Text)) - (|> (list;zip2 representations values) + (|> (list.zip2 representations values) (list/map (function [[representation value]] (representation value))))) (def: primitive-representation (Poly Representation) - (`` ($_ p;either - (do p;Monad<Parser> - [_ poly;unit] + (`` ($_ p.either + (do p.Monad<Parser> + [_ poly.unit] (wrap (const "[]"))) (~~ (do-template [<parser> <type> <formatter>] - [(do p;Monad<Parser> + [(do p.Monad<Parser> [_ <parser>] - (wrap (|>. (:! <type>) <formatter>)))] + (wrap (|>> (:! <type>) <formatter>)))] - [poly;bool Bool %b] - [poly;nat Nat %n] - [poly;int Int %i] - [poly;deg Deg %d] - [poly;frac Frac %f] - [poly;text Text %t]))))) + [poly.bool Bool %b] + [poly.nat Nat %n] + [poly.int Int %i] + [poly.deg Deg %d] + [poly.frac Frac %f] + [poly.text Text %t]))))) (def: (special-representation representation) (-> (Poly Representation) (Poly Representation)) - (`` ($_ p;either + (`` ($_ p.either (~~ (do-template [<type> <formatter>] - [(do p;Monad<Parser> - [_ (poly;this <type>)] - (wrap (|>. (:! <type>) <formatter>)))] + [(do p.Monad<Parser> + [_ (poly.this <type>)] + (wrap (|>> (:! <type>) <formatter>)))] [Type %type] [Code %code] @@ -115,201 +115,201 @@ [XML %xml] )) - (do p;Monad<Parser> - [[_ elemT] (poly;apply (p;seq (poly;this List) poly;any)) - elemR (poly;local (list elemT) representation)] - (wrap (|>. (:! (List Top)) (%list elemR)))) + (do p.Monad<Parser> + [[_ elemT] (poly.apply (p.seq (poly.this List) poly.any)) + elemR (poly.local (list elemT) representation)] + (wrap (|>> (:! (List Top)) (%list elemR)))) - (do p;Monad<Parser> - [[_ elemT] (poly;apply (p;seq (poly;this Maybe) poly;any)) - elemR (poly;local (list elemT) representation)] - (wrap (|>. (:! (Maybe Top)) - (case> #;None - "#;None" + (do p.Monad<Parser> + [[_ elemT] (poly.apply (p.seq (poly.this Maybe) poly.any)) + elemR (poly.local (list elemT) representation)] + (wrap (|>> (:! (Maybe Top)) + (case> #.None + "#.None" - (#;Some elemV) - (elemR elemV)))))))) + (#.Some elemV) + (format "(#.Some " (elemR elemV) ")")))))))) (def: (record-representation tags representation) (-> (List Ident) (Poly Representation) (Poly Representation)) - (do p;Monad<Parser> - [membersR+ (poly;tuple (p;many representation)) - _ (p;assert "Number of tags does not match record type size." - (n.= (list;size tags) (list;size membersR+)))] + (do p.Monad<Parser> + [membersR+ (poly.tuple (p.many representation)) + _ (p.assert "Number of tags does not match record type size." + (n/= (list.size tags) (list.size membersR+)))] (wrap (function [recordV] - (let [record-body (loop [pairs-left (list;zip2 tags membersR+) + (let [record-body (loop [pairs-left (list.zip2 tags membersR+) recordV recordV] (case pairs-left - #;Nil + #.Nil "" - (#;Cons [tag repr] #;Nil) - (format (%code (code;tag tag)) " " (repr recordV)) + (#.Cons [tag repr] #.Nil) + (format (%code (code.tag tag)) " " (repr recordV)) - (#;Cons [tag repr] tail) + (#.Cons [tag repr] tail) (let [[leftV rightV] (:! [Top Top] recordV)] - (format (%code (code;tag tag)) " " (repr leftV) " " + (format (%code (code.tag tag)) " " (repr leftV) " " (recur tail rightV)))))] (format "{" record-body "}")))))) (def: (variant-representation tags representation) (-> (List Ident) (Poly Representation) (Poly Representation)) - (do p;Monad<Parser> - [casesR+ (poly;variant (p;many representation)) - #let [num-tags (list;size tags)] - _ (p;assert "Number of tags does not match variant type size." - (n.= num-tags (list;size casesR+)))] + (do p.Monad<Parser> + [casesR+ (poly.variant (p.many representation)) + #let [num-tags (list.size tags)] + _ (p.assert "Number of tags does not match variant type size." + (n/= num-tags (list.size casesR+)))] (wrap (function [variantV] - (loop [cases-left (list;zip3 tags - (list;n.range +0 (n.dec num-tags)) + (loop [cases-left (list.zip3 tags + (list.n/range +0 (n/dec num-tags)) casesR+) variantV variantV] (case cases-left - #;Nil + #.Nil "" - (#;Cons [tag-name tag-idx repr] #;Nil) + (#.Cons [tag-name tag-idx repr] #.Nil) (let [[_tag _last? _value] (:! [Nat Text Top] variantV)] - (if (n.= tag-idx _tag) - (format "(" (%code (code;tag tag-name)) " " (repr _value) ")") + (if (n/= tag-idx _tag) + (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") (undefined))) - (#;Cons [tag-name tag-idx repr] tail) + (#.Cons [tag-name tag-idx repr] tail) (let [[_tag _last? _value] (:! [Nat Text Top] variantV)] - (if (n.= tag-idx _tag) - (format "(" (%code (code;tag tag-name)) " " (repr _value) ")") + (if (n/= tag-idx _tag) + (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") (recur tail variantV))))))))) (def: (tagged-representation compiler representation) (-> Compiler (Poly Representation) (Poly Representation)) - (do p;Monad<Parser> - [[name anonymous] poly;named] - (case (macro;run compiler (macro;tags-of name)) - (#e;Success ?tags) + (do p.Monad<Parser> + [[name anonymous] poly.named] + (case (macro.run compiler (macro.tags-of name)) + (#e.Success ?tags) (case ?tags - (#;Some tags) - (poly;local (list anonymous) - (p;either (record-representation tags representation) + (#.Some tags) + (poly.local (list anonymous) + (p.either (record-representation tags representation) (variant-representation tags representation))) - #;None + #.None representation) - (#e;Error error) - (p;fail error)))) + (#e.Error error) + (p.fail error)))) (def: (tuple-representation representation) (-> (Poly Representation) (Poly Representation)) - (do p;Monad<Parser> - [membersR+ (poly;tuple (p;many representation))] + (do p.Monad<Parser> + [membersR+ (poly.tuple (p.many representation))] (wrap (function [tupleV] (let [tuple-body (loop [representations membersR+ tupleV tupleV] (case representations - #;Nil + #.Nil "" - (#;Cons lastR #;Nil) + (#.Cons lastR #.Nil) (lastR tupleV) - (#;Cons headR tailR) + (#.Cons headR tailR) (let [[leftV rightV] (:! [Top Top] tupleV)] (format (headR leftV) " " (recur tailR rightV)))))] (format "[" tuple-body "]")))))) (def: (representation compiler) (-> Compiler (Poly Representation)) - (p;rec + (p.rec (function [representation] - ($_ p;either + ($_ p.either primitive-representation (special-representation representation) (tagged-representation compiler representation) (tuple-representation representation) - (do p;Monad<Parser> - [[funcT inputsT+] (poly;apply (p;seq poly;any (p;many poly;any)))] - (case (type;apply inputsT+ funcT) - (#;Some outputT) - (poly;local (list outputT) representation) + (do p.Monad<Parser> + [[funcT inputsT+] (poly.apply (p.seq poly.any (p.many poly.any)))] + (case (type.apply inputsT+ funcT) + (#.Some outputT) + (poly.local (list outputT) representation) - #;None - (p;fail ""))) + #.None + (p.fail ""))) - (do p;Monad<Parser> - [[name anonymous] poly;named] - (poly;local (list anonymous) representation)) + (do p.Monad<Parser> + [[name anonymous] poly.named] + (poly.local (list anonymous) representation)) - (p;fail "") + (p.fail "") )))) (def: (represent compiler type value) (-> Compiler Type Top Text) - (case (poly;run type (representation compiler)) - (#e;Success representation) + (case (poly.run type (representation compiler)) + (#e.Success representation) (representation value) - (#e;Error error) + (#e.Error error) ". . . cannot represent value . . .")) (def: (repl-translate source-dirs target-dir code) (-> (List File) File Code (Meta [Type Top])) (function [compiler] - (case ((translationL;translate (translationL;translate-module source-dirs target-dir) + (case ((translationL.translate (translationL.translate-module source-dirs target-dir) no-aliases code) compiler) - (#e;Success [compiler' aliases']) - (#e;Success [compiler' [Void []]]) - - (#e;Error error) - (if (ex;match? translationL;Unrecognized-Statement error) - ((do macro;Monad<Meta> - [[var-id varT] (lang;with-type-env check;var) - exprV (scopeL;with-scope repl-module - (evalL;eval varT code)) - ?exprT (lang;with-type-env (check;read var-id))] - (wrap [(maybe;assume ?exprT) exprV])) + (#e.Success [compiler' aliases']) + (#e.Success [compiler' [Void []]]) + + (#e.Error error) + (if (ex.match? translationL.Unrecognized-Statement error) + ((do macro.Monad<Meta> + [[var-id varT] (lang.with-type-env check.var) + exprV (scopeL.with-scope repl-module + (evalL.eval varT code)) + ?exprT (lang.with-type-env (check.read var-id))] + (wrap [(maybe.assume ?exprT) exprV])) compiler) - (#e;Error error))))) + (#e.Error error))))) (def: fresh-source Source [[repl-module +1 +0] +0 ""]) (def: #export (run source-dirs target-dir) (-> (List File) File (Task Unit)) - (do task;Monad<Task> - [console (promise;future console;open) + (do task.Monad<Task> + [console (promise.future console.open) compiler (initialize source-dirs target-dir console)] (loop [compiler compiler source fresh-source multi-line? false] (do @ [_ (if multi-line? - (console;write " " console) - (console;write "> " console)) - line (console;read-line console)] + (console.write " " console) + (console.write "> " console)) + line (console.read-line console)] (if (text/= "exit" line) - (console;write "Till next time..." console) - (case (do e;Monad<Error> - [[source' exprC] (syntax;read repl-module no-aliases (add-line line source))] - (macro;run' compiler - (lang;with-current-module repl-module - (do macro;Monad<Meta> + (console.write "Till next time..." console) + (case (do e.Monad<Error> + [[source' exprC] (syntax.read repl-module no-aliases (add-line line source))] + (macro.run' compiler + (lang.with-current-module repl-module + (do macro.Monad<Meta> [[exprT exprV] (repl-translate source-dirs target-dir exprC) - ## [var-id varT] (lang;with-type-env check;var) - ## exprV (evalL;eval varT exprC) - ## ?exprT (lang;with-type-env (check;read var-id)) + ## [var-id varT] (lang.with-type-env check.var) + ## exprV (evalL.eval varT exprC) + ## ?exprT (lang.with-type-env (check.read var-id)) ] (wrap [source' exprT exprV]))))) - (#e;Success [compiler' [source' exprT exprV]]) + (#e.Success [compiler' [source' exprT exprV]]) (do @ - [_ (console;write (format " Type: " (type;to-text exprT) "\n" + [_ (console.write (format " Type: " (type.to-text exprT) "\n" "Value: " (represent compiler' exprT exprV) "\n\n") console)] (recur compiler' source' false)) - (#e;Error error) - (if (ex;match? syntax;End-Of-File error) + (#e.Error error) + (if (ex.match? syntax.End-Of-File error) (recur compiler source true) (exec (log! (REPL-Error error)) (recur compiler fresh-source false)))))) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 5708211fd..c36fb2114 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["p" parser]) @@ -9,50 +9,50 @@ [io #- run] [cli #+ program: CLI]) (luxc [repl] - (lang [";L" translation]))) + (lang [".L" translation]))) ## (type: Compilation -## {#program &;Path -## #target &;Path}) +## {#program &.Path +## #target &.Path}) ## (def: (marker tokens) ## (-> (List Text) (CLI Unit)) -## (cli;after (cli;option tokens) +## (cli.after (cli.option tokens) ## (:: Monad<CLI> wrap []))) ## (def: (tagged tags) ## (-> (List Text) (CLI Text)) -## (cli;after (cli;option tags) -## cli;any)) +## (cli.after (cli.option tags) +## cli.any)) ## (def: compilation^ ## (CLI Compilation) -## ($_ cli;seq +## ($_ cli.seq ## (tagged (list "-p" "--program")) ## (tagged (list "-t" "--target")))) -## (program: ([command (cli;opt compilation^)] -## [sources (cli;some (tagged (list "-s" "--source")))]) +## (program: ([command (cli.opt compilation^)] +## [sources (cli.some (tagged (list "-s" "--source")))]) ## (case command -## #;None +## #.None ## (io (log! "No REPL for you!")) -## (#;Some [program target]) -## (exec (&compiler;compile-program program target sources) +## (#.Some [program target]) +## (exec (&compiler.compile-program program target sources) ## (io [])))) (def: (or-crash! failure-describer action) - (All [a] (-> Text (T;Task a) (P;Promise a))) - (do P;Monad<Promise> + (All [a] (-> Text (T.Task a) (P.Promise a))) + (do P.Monad<Promise> [?output action] (case ?output - (#e;Error error) + (#e.Error error) (exec (log! (format "\n" failure-describer "\n" error "\n")) ("lux io exit" 1)) - (#e;Success output) + (#e.Success output) (wrap output)))) |