diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/type.lux | 27 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/extension/analysis.lux | 19 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis.lux | 17 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/expression.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension.lux (renamed from new-luxc/source/luxc/lang/extension.lux) | 59 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension/analysis.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension/analysis/common.lux (renamed from new-luxc/source/luxc/lang/extension/analysis/common.lux) | 146 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension/analysis/host.jvm.lux (renamed from new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux) | 560 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/init.lux | 31 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis.lux (renamed from new-luxc/source/luxc/lang/synthesis.lux) | 0 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/procedure/common.lux (renamed from new-luxc/test/test/luxc/lang/analysis/procedure/common.lux) | 134 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux (renamed from new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux) | 119 |
12 files changed, 557 insertions, 582 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux deleted file mode 100644 index 6d89dd5ef..000000000 --- a/new-luxc/source/luxc/lang/analysis/type.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - lux - (lux (control monad) - [macro] - (lang (type ["tc" check]))) - (luxc ["&" lang] - (lang ["la" analysis #+ Analysis]))) - -## These 2 analysers are somewhat special, since they require the -## 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> - [actualT (eval Type type) - #let [actualT (:! 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> - [actualT (eval Type type) - _ (&.infer (:! Type actualT))] - (&.with-type Any - (analyse value)))) diff --git a/new-luxc/source/luxc/lang/extension/analysis.lux b/new-luxc/source/luxc/lang/extension/analysis.lux deleted file mode 100644 index 79fa3af88..000000000 --- a/new-luxc/source/luxc/lang/extension/analysis.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict])))) - [//] - [/common] - [/host]) - -(def: realize - (-> /common.Bundle (Dict Text //.Analysis)) - (|>> dict.entries - (list/map (function (_ [name proc]) [name (proc name)])) - (dict.from-list text.Hash<Text>))) - -(def: #export defaults - (Dict Text //.Analysis) - (realize (dict.merge /common.procedures - /host.procedures))) diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 0b48f803d..324f12b3e 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -1,5 +1,5 @@ (.module: - lux + [lux #- nat int deg] (lux [function] (data (coll [list "list/" Fold<List>])))) @@ -46,7 +46,20 @@ (#Apply Analysis Analysis) (#Variable Variable) (#Constant Ident) - (#Special (Special Text))) + (#Special (Special Analysis))) + +(do-template [<name> <type> <tag>] + [(def: #export <name> + (-> <type> Analysis) + (|>> <tag> #Primitive))] + + [bool Bool #Bool] + [nat Nat #Nat] + [int Int #Int] + [deg Deg #Deg] + [frac Frac #Frac] + [text Text #Text] + ) (type: #export (Variant a) {#lefts Nat diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux index da1b27a10..325394e73 100644 --- a/stdlib/source/lux/lang/analysis/expression.lux +++ b/stdlib/source/lux/lang/analysis/expression.lux @@ -15,8 +15,7 @@ [".A" structure] [".A" reference]) ## [".L" macro] - ## [".L" extension] - ))) + [".L" extension]))) (exception: #export (macro-expansion-failed {message Text}) message) @@ -80,10 +79,10 @@ (#.Symbol reference) (referenceA.reference reference) - ## (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) - ## (do macro.Monad<Meta> - ## [procedure (extensionL.find-analysis proc-name)] - ## (procedure analyse eval proc-args)) + (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) + (do macro.Monad<Meta> + [procedure (extensionL.find-analysis proc-name)] + (procedure analyse eval proc-args)) ## (^ (#.Form (list& func args))) ## (do macro.Monad<Meta> diff --git a/new-luxc/source/luxc/lang/extension.lux b/stdlib/source/lux/lang/extension.lux index 254dd18ca..03fd81d71 100644 --- a/new-luxc/source/luxc/lang/extension.lux +++ b/stdlib/source/lux/lang/extension.lux @@ -6,34 +6,30 @@ [text] (coll (dictionary ["dict" unordered #+ Dict]))) [macro]) - [//] - (// ["la" analysis] - ["ls" synthesis])) + [// #+ Eval] + (// [".L" analysis #+ Analyser] + [".L" synthesis])) (do-template [<name>] [(exception: #export (<name> {message Text}) message)] - [Unknown-Analysis] - [Unknown-Synthesis] - [Unknown-Translation] - [Unknown-Statement] + [unknown-analysis] + [unknown-synthesis] + [unknown-translation] + [unknown-statement] - [Cannot-Define-Analysis-More-Than-Once] - [Cannot-Define-Synthesis-More-Than-Once] - [Cannot-Define-Translation-More-Than-Once] - [Cannot-Define-Statement-More-Than-Once] + [cannot-define-analysis-more-than-once] + [cannot-define-synthesis-more-than-once] + [cannot-define-translation-more-than-once] + [cannot-define-statement-more-than-once] ) (type: #export Analysis - (-> (-> Code (Meta Code)) - (-> Type Code (Meta Any)) - (List Code) (Meta Code))) + (-> Analyser Eval (List Code) (Meta analysisL.Analysis))) (type: #export Synthesis - (-> (-> la.Analysis ls.Synthesis) (List Code) Code)) - -(type: #export Syntheses (Dict Text Synthesis)) + (-> (-> analysisL.Analysis synthesisL.Synthesis) (List Code) Code)) (type: #export Translation (-> (List Code) (Meta Code))) @@ -41,11 +37,14 @@ (type: #export Statement (-> (List Code) (Meta Any))) +(type: #export (Extension e) + (Dict Text e)) + (type: #export Extensions - {#analysis (Dict Text Analysis) - #synthesis Syntheses - #translation (Dict Text Translation) - #statement (Dict Text Statement)}) + {#analysis (Extension Analysis) + #synthesis (Extension Synthesis) + #translation (Extension Translation) + #statement (Extension Statement)}) (def: #export fresh Extensions @@ -78,10 +77,10 @@ #.None (//.throw <exception> name))))] - [find-analysis Analysis #analysis Unknown-Analysis] - [find-synthesis Synthesis #synthesis Unknown-Synthesis] - [find-translation Translation #translation Unknown-Translation] - [find-statement Statement #statement Unknown-Statement] + [find-analysis Analysis #analysis unknown-analysis] + [find-synthesis Synthesis #synthesis unknown-synthesis] + [find-translation Translation #translation unknown-translation] + [find-statement Statement #statement unknown-statement] ) (do-template [<no> <all> <type> <category> <empty>] @@ -94,7 +93,7 @@ (|> ..get (:: macro.Monad<Meta> map (get@ <category>))))] - [no-syntheses all-syntheses Syntheses #synthesis (dict.new text.Hash<Text>)] + [no-syntheses all-syntheses (Extension Synthesis) #synthesis (dict.new text.Hash<Text>)] ) (do-template [<name> <type> <category> <exception>] @@ -107,8 +106,8 @@ _ (..set (update@ <category> (dict.put name extension) extensions))] (wrap [])))] - [install-analysis Analysis #analysis Cannot-Define-Analysis-More-Than-Once] - [install-synthesis Synthesis #synthesis Cannot-Define-Synthesis-More-Than-Once] - [install-translation Translation #translation Cannot-Define-Translation-More-Than-Once] - [install-statement Statement #statement Cannot-Define-Statement-More-Than-Once] + [install-analysis Analysis #analysis cannot-define-analysis-more-than-once] + [install-synthesis Synthesis #synthesis cannot-define-synthesis-more-than-once] + [install-translation Translation #translation cannot-define-translation-more-than-once] + [install-statement Statement #statement cannot-define-statement-more-than-once] ) diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/extension/analysis.lux new file mode 100644 index 000000000..40fd84679 --- /dev/null +++ b/stdlib/source/lux/lang/extension/analysis.lux @@ -0,0 +1,16 @@ +(.module: + lux + (lux (data [text] + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered #+ Dict])))) + [//] + [/common] + [/host]) + +(def: #export defaults + (//.Extension //.Analysis) + (|> /common.specials + (dict.merge /host.specials) + dict.entries + (list/map (function (_ [name proc]) [name (proc name)])) + (dict.from-list text.Hash<Text>))) diff --git a/new-luxc/source/luxc/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux index f22cdcdd1..8c0116721 100644 --- a/new-luxc/source/luxc/lang/extension/analysis/common.lux +++ b/stdlib/source/lux/lang/extension/analysis/common.lux @@ -1,7 +1,8 @@ (.module: lux (lux (control [monad #+ do] - ["ex" exception #+ exception:]) + ["ex" exception #+ exception:] + [thread]) (concurrency [atom #+ Atom]) (data [text] text/format @@ -10,23 +11,27 @@ (dictionary ["dict" unordered #+ Dict]))) [macro] (macro [code]) - (lang (type ["tc" check])) + [lang] + (lang (type ["tc" check]) + [".L" analysis] + (analysis [".A" type] + [".A" case] + [".A" function])) [io]) - (luxc ["&" lang] - (lang ["la" analysis] - (analysis ["&." common] - [".A" function] - [".A" case] - [".A" type]))) [///]) -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] +(exception: #export (incorrect-special-arity {name Text} {arity Nat} {args Nat}) + (ex.report ["Special" (%t name)] + ["Expected arity" (|> arity .int %i)] + ["Actual arity" (|> args .int %i)])) - [Incorrect-Procedure-Arity] - [Invalid-Syntax] - ) +(exception: #export (invalid-syntax {name Text} {arguments (List Code)}) + (ex.report ["Special" name] + ["Inputs" (|> arguments + list.enumerate + (list/map (function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) ## [Utils] (type: #export Bundle @@ -44,12 +49,6 @@ (list/map (function (_ [key val]) [(format prefix " " key) val])) (dict.from-list text.Hash<Text>))) -(def: #export (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format " Procedure: " (%t proc) "\n" - " Expected Arity: " (|> expected nat-to-int %i) "\n" - " Actual Arity: " (|> actual nat-to-int %i))) - (def: (simple proc inputsT+ outputT) (-> Text (List Type) Type ///.Analysis) (let [num-expected (list.size inputsT+)] @@ -57,14 +56,14 @@ (let [num-actual (list.size args)] (if (n/= num-expected num-actual) (do macro.Monad<Meta> - [_ (&.infer outputT) + [_ (typeA.infer outputT) argsA (monad.map @ (function (_ [argT argC]) - (&.with-type argT + (typeA.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))))))) + (wrap (#analysisL.Special proc argsA))) + (lang.throw incorrect-special-arity [proc num-expected num-actual])))))) (def: #export (nullary valueT proc) (-> Type Text ///.Analysis) @@ -88,7 +87,7 @@ (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] ((binary varT varT Bool proc) analyse eval args)))) @@ -100,14 +99,14 @@ (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)) + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (io.IO varT)) (analyse opC))] - (wrap (la.procedure proc (list opA)))) + (wrap (#analysisL.Special proc (list opA)))) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) (def: (lux//function proc) (-> Text ///.Analysis) @@ -116,50 +115,50 @@ (^ (list [_ (#.Symbol ["" func-name])] [_ (#.Symbol ["" arg-name])] body)) - (functionA.analyse-function analyse func-name arg-name body) + (functionA.function analyse func-name arg-name body) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args)))))) + (lang.throw incorrect-special-arity [proc +3 (list.size args)])))) (def: (lux//case proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list input [_ (#.Record branches)])) - (caseA.analyse-case analyse input branches) + (caseA.case analyse input branches) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args)))))) + (lang.throw incorrect-special-arity [proc +2 (list.size args)])))) (def: (lux//in-module proc) (-> Text ///.Analysis) (function (_ analyse eval argsC+) (case argsC+ (^ (list [_ (#.Text module-name)] exprC)) - (&.with-current-module module-name + (lang.with-current-module module-name (analyse exprC)) _ - (&.throw Invalid-Syntax (format "Procedure: " proc "\n" - " Inputs:" (|> argsC+ - list.enumerate - (list/map (function (_ [idx argC]) - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with "")) "\n"))))) - -(do-template [<name> <analyser>] + (lang.throw invalid-syntax [proc argsC+])))) + +(do-template [<name> <type>] [(def: (<name> proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list typeC valueC)) - (<analyser> analyse eval typeC valueC) + (do macro.Monad<Meta> + [actualT (eval Type typeC) + _ (typeA.infer (:! Type actualT))] + (typeA.with-type <type> + (analyse valueC))) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))] + (lang.throw incorrect-special-arity [proc +2 (list.size args)]))))] - [lux//check typeA.analyse-check] - [lux//coerce typeA.analyse-coerce]) + [lux//check (:! Type actualT)] + [lux//coerce Any] + ) (def: (lux//check//type proc) (-> Text ///.Analysis) @@ -167,13 +166,13 @@ (case args (^ (list valueC)) (do macro.Monad<Meta> - [_ (&.infer (type Type)) - valueA (&.with-type Type + [_ (typeA.infer Type) + valueA (typeA.with-type Type (analyse valueC))] (wrap valueA)) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) (def: lux-procs Bundle @@ -284,7 +283,7 @@ (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) analyse eval args)))) @@ -292,7 +291,7 @@ (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) analyse eval args)))) @@ -300,7 +299,7 @@ (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] ((binary (type (Array varT)) Nat (type (Array varT)) proc) analyse eval args)))) @@ -343,20 +342,20 @@ (case args (^ (list initC)) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var) - _ (&.infer (type (Atom varT))) - initA (&.with-type varT + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Atom varT))) + initA (typeA.with-type varT (analyse initC))] - (wrap (la.procedure proc (list initA)))) + (wrap (#analysisL.Special proc (list initA)))) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) (def: (atom-read proc) (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] ((unary (type (Atom varT)) varT proc) analyse eval args)))) @@ -364,7 +363,7 @@ (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] ((trinary (type (Atom varT)) varT varT Bool proc) analyse eval args)))) @@ -377,40 +376,37 @@ (install "compare-and-swap" atom//compare-and-swap) ))) -(type: (Box ! a) - (#.Primitive "#Box" (#.Cons ! (#.Cons a #.Nil)))) - (def: (box//new proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list initC)) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var) - _ (&.infer (type (All [!] (Box ! varT)))) - initA (&.with-type varT + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (All [!] (thread.Box ! varT)))) + initA (typeA.with-type varT (analyse initC))] - (wrap (la.procedure proc (list initA)))) + (wrap (#analysisL.Special proc (list initA)))) _ - (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) (def: (box//read proc) (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[thread-id threadT] (&.with-type-env tc.var) - [var-id varT] (&.with-type-env tc.var)] - ((unary (type (Box threadT varT)) varT proc) + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((unary (type (thread.Box threadT varT)) varT proc) analyse eval args)))) (def: (box//write proc) (-> Text ///.Analysis) (function (_ analyse eval args) (do macro.Monad<Meta> - [[thread-id threadT] (&.with-type-env tc.var) - [var-id varT] (&.with-type-env tc.var)] - ((binary varT (type (Box threadT varT)) Any proc) + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((binary varT (type (thread.Box threadT varT)) Any proc) analyse eval args)))) (def: box-procs @@ -430,7 +426,7 @@ (install "schedule" (binary Nat (type (io.IO Any)) Any)) ))) -(def: #export procedures +(def: #export specials Bundle (<| (prefix "lux") (|> (dict.new text.Hash<Text>) diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux index 9ef06a4b1..31b811fac 100644 --- a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux @@ -1,5 +1,5 @@ (.module: - [lux #- char] + [lux #- char int] (lux (control [monad #+ do] ["p" parser] ["ex" exception #+ exception:]) @@ -17,31 +17,47 @@ [macro "macro/" Monad<Meta>] (macro [code] ["s" syntax]) + [lang] (lang [type] - (type ["tc" check])) + (type ["tc" check]) + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" inference])) [host]) - (luxc ["&" lang] - (lang ["&." host] - ["la" analysis] - (analysis ["&." common] - [".A" inference]))) - ["@" //common] + ["/" //common] [///] ) +(host.import #long java/lang/reflect/Type + (getTypeName [] String)) + +(def: jvm-type-name + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) + +(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) + (jvm-type-name jvm-type)) + (do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] + [(exception: #export (<name> {type Type}) + (%type type))] - [Wrong-Syntax] + [non-object] + [non-array] + [non-jvm-type] + ) - [JVM-Type-Is-Not-Class] +(do-template [<name>] + [(exception: #export (<name> {name Text}) + name)] - [Non-Interface] - [Non-Object] - [Non-Array] - [Non-Throwable] - [Non-JVM-Type] + [non-interface] + [non-throwable] + ) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] [Unknown-Class] [Primitives-Cannot-Have-Type-Parameters] @@ -69,11 +85,6 @@ [Cannot-Correspond-Type-With-Class] ) -(def: (wrong-syntax procedure args) - (-> Text (List Code) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - (do-template [<name> <class>] [(def: #export <name> Type (#.Primitive <class> (list)))] @@ -100,52 +111,52 @@ ) (def: conversion-procs - @.Bundle - (<| (@.prefix "convert") + /.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)) + (/.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>) + /.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>)) + (/.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] @@ -154,16 +165,16 @@ (do-template [<name> <prefix> <type>] [(def: <name> - @.Bundle - (<| (@.prefix <prefix>) + /.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 "+" (/.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] @@ -171,11 +182,11 @@ ) (def: char-procs - @.Bundle - (<| (@.prefix "char") + /.Bundle + (<| (/.prefix "char") (|> (dict.new text.Hash<Text>) - (@.install "=" (@.binary Character Character Boolean)) - (@.install "<" (@.binary Character Character Boolean)) + (/.install "=" (/.binary Character Character Boolean)) + (/.install "<" (/.binary Character Character Boolean)) ))) (def: #export boxes @@ -190,28 +201,28 @@ ["char" "java.lang.Character"]) (dict.from-list text.Hash<Text>))) -(def: (array-length proc) +(def: (array//length proc) (-> Text ///.Analysis) (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)) + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env tc.var) + arrayA (typeA.with-type (type (Array varT)) (analyse arrayC))] - (wrap (la.procedure proc (list arrayA)))) + (wrap (#analysisL.Special proc (list arrayA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) -(def: (array-new proc) +(def: (array//new proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list lengthC)) (do macro.Monad<Meta> - [lengthA (&.with-type Nat + [lengthA (typeA.with-type Nat (analyse lengthC)) expectedT macro.expected-type [level elem-class] (: (Meta [Nat Text]) @@ -224,23 +235,25 @@ (recur outputT level) #.None - (&.throw Non-Array (%type expectedT))) + (lang.throw non-array expectedT)) (^ (#.Primitive "#Array" (list elemT))) - (recur elemT (n/inc level)) + (recur elemT (inc level)) (#.Primitive class _) (wrap [level class]) _ - (&.throw Non-Array (%type expectedT))))) + (lang.throw non-array 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)))) + (lang.throw non-array expectedT))] + (wrap (#analysisL.Special proc (list (analysisL.nat (dec level)) + (analysisL.text elem-class) + lengthA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) (def: (check-jvm objectT) (-> Type (Meta Text)) @@ -266,17 +279,17 @@ (check-jvm outputT) #.None - (&.throw Non-Object (%type objectT))) + (lang.throw non-object objectT)) _ - (&.throw Non-Object (%type objectT)))) + (lang.throw non-object objectT))) (def: (check-object objectT) (-> Type (Meta Text)) (do macro.Monad<Meta> [name (check-jvm objectT)] (if (dict.contains? name boxes) - (&.throw Primitives-Are-Not-Objects name) + (lang.throw Primitives-Are-Not-Objects name) (macro/wrap name)))) (def: (box-array-element-type elemT) @@ -290,62 +303,62 @@ (#.Primitive name _) (if (dict.contains? name boxes) - (&.throw Primitives-Cannot-Have-Type-Parameters name) + (lang.throw Primitives-Cannot-Have-Type-Parameters name) (macro/wrap [elemT name])) _ - (&.throw Invalid-Type-For-Array-Element (%type elemT)))) + (lang.throw Invalid-Type-For-Array-Element (%type elemT)))) -(def: (array-read proc) +(def: (array//read proc) (-> Text ///.Analysis) (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)) + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&.with-type-env + ?elemT (typeA.with-env (tc.read var-id)) [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (&.with-type Nat + idxA (typeA.with-type Nat (analyse idxC))] - (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA)))) + (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA arrayA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) -(def: (array-write proc) +(def: (array//write proc) (-> Text ///.Analysis) (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)) + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&.with-type-env + ?elemT (typeA.with-env (tc.read var-id)) [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (&.with-type Nat + idxA (typeA.with-type Nat (analyse idxC)) - valueA (&.with-type valueT + valueA (typeA.with-type valueT (analyse valueC))] - (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA)))) + (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA valueA arrayA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +3 (list.size args)])))) (def: array-procs - @.Bundle - (<| (@.prefix "array") + /.Bundle + (<| (/.prefix "array") (|> (dict.new text.Hash<Text>) - (@.install "length" array-length) - (@.install "new" array-new) - (@.install "read" array-read) - (@.install "write" array-write) + (/.install "length" array//length) + (/.install "new" array//new) + (/.install "read" array//read) + (/.install "write" array//write) ))) (def: (object//null proc) @@ -356,10 +369,10 @@ (do macro.Monad<Meta> [expectedT macro.expected-type _ (check-object expectedT)] - (wrap (la.procedure proc (list)))) + (wrap (#analysisL.Special proc (list)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +0 (list.size args)])))) (def: (object//null? proc) (-> Text ///.Analysis) @@ -367,14 +380,14 @@ (case args (^ (list objectC)) (do macro.Monad<Meta> - [_ (&.infer Bool) - [objectT objectA] (&common.with-unknown-type + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference (analyse objectC)) _ (check-object objectT)] - (wrap (la.procedure proc (list objectA)))) + (wrap (#analysisL.Special proc (list objectA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) (def: (object//synchronized proc) (-> Text ///.Analysis) @@ -382,23 +395,20 @@ (case args (^ (list monitorC exprC)) (do macro.Monad<Meta> - [[monitorT monitorA] (&common.with-unknown-type + [[monitorT monitorA] (typeA.with-inference (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (la.procedure proc (list monitorA exprA)))) + (wrap (#analysisL.Special proc (list monitorA exprA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) (host.import java/lang/Object (equals [Object] boolean)) (host.import java/lang/ClassLoader) -(host.import #long java/lang/reflect/Type - (getTypeName [] String)) - (host.import java/lang/reflect/GenericArrayType (getGenericComponentType [] java/lang/reflect/Type)) @@ -444,7 +454,7 @@ (host.import (java/lang/Class c) (getName [] String) (getModifiers [] int) - (#static forName [String boolean ClassLoader] #try (Class Object)) + (#static forName [String] #try (Class Object)) (isAssignableFrom [(Class Object)] boolean) (getTypeParameters [] (Array (TypeVariable (Class c)))) (getGenericInterfaces [] (Array java/lang/reflect/Type)) @@ -456,13 +466,13 @@ (def: (load-class name) (-> Text (Meta (Class Object))) (do macro.Monad<Meta> - [class-loader &host.class-loader] - (case (Class::forName [name false class-loader]) + [] + (case (Class::forName [name]) (#e.Success [class]) (wrap class) (#e.Error error) - (&.throw Unknown-Class name)))) + (lang.throw Unknown-Class name)))) (def: (sub-class? super sub) (-> Text Text (Meta Bool)) @@ -477,19 +487,19 @@ (case args (^ (list exceptionC)) (do macro.Monad<Meta> - [_ (&.infer Nothing) - [exceptionT exceptionA] (&common.with-unknown-type + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Meta Any) (if ? (wrap []) - (&.throw Non-Throwable exception-class)))] - (wrap (la.procedure proc (list exceptionA)))) + (lang.throw non-throwable exception-class)))] + (wrap (#analysisL.Special proc (list exceptionA)))) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) (def: (object//class proc) (-> Text ///.Analysis) @@ -499,15 +509,15 @@ (case classC [_ (#.Text class)] (do macro.Monad<Meta> - [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] - (wrap (la.procedure proc (list (code.text class))))) + (wrap (#analysisL.Special proc (list (analysisL.text class))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))) + (lang.throw /.invalid-syntax [proc args])) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) (def: (object//instance? proc) (-> Text ///.Analysis) @@ -517,24 +527,20 @@ (case classC [_ (#.Text class)] (do macro.Monad<Meta> - [_ (&.infer Bool) - [objectT objectA] (&common.with-unknown-type + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference (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 (#analysisL.Special proc (list (analysisL.text class)))) + (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))) + (lang.throw /.invalid-syntax [proc args])) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) - -(def: type-descriptor - (-> java/lang/reflect/Type Text) - (java/lang/reflect/Type::getTypeName [])) + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) (def: (java-type-to-class type) (-> java/lang/reflect/Type (Meta Text)) @@ -545,7 +551,7 @@ (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) ## else - (&.throw Cannot-Convert-To-Class (type-descriptor type)))) + (lang.throw Cannot-Convert-To-Class (jvm-type-name type)))) (type: Mappings (Dict Text Type)) @@ -561,7 +567,7 @@ (macro/wrap var-type) #.None - (&.throw Unknown-Type-Var var-name))) + (lang.throw Unknown-Type-Var var-name))) (host.instance? WildcardType java-type) (let [java-type (:! WildcardType java-type)] @@ -581,9 +587,9 @@ (#.Primitive class-name (list)) arity - (|> (list.n/range +0 (n/dec arity)) + (|> (list.n/range +0 (dec arity)) list.reverse - (list/map (|>> (n/* +2) n/inc #.Bound)) + (list/map (|>> (n/* +2) inc #.Bound)) (#.Primitive class-name) (type.univ-q arity))))) @@ -598,7 +604,7 @@ (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)))) + (lang.throw jvm-type-is-not-a-class raw))) (host.instance? GenericArrayType java-type) (do macro.Monad<Meta> @@ -608,7 +614,7 @@ (wrap (#.Primitive "#Array" (list innerT)))) ## else - (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) + (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type)))) (def: (correspond-type-params class type) (-> (Class Object) Type (Meta Mappings)) @@ -619,16 +625,16 @@ 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 - (format "Class = " class-name "\n" - "Type = " (%type type))) + (lang.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 - (format "Expected: " (%i (nat-to-int num-class-params)) "\n" - " Actual: " (%i (nat-to-int num-type-params)) "\n" - " Class: " class-name "\n" - " Type: " (%type type))) + (lang.throw Type-Parameter-Mismatch + (format "Expected: " (%i (.int num-class-params)) "\n" + " Actual: " (%i (.int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) ## else (macro/wrap (|> params @@ -637,7 +643,7 @@ )) _ - (&.throw Non-JVM-Type (%type type)))) + (lang.throw non-jvm-type type))) (def: (object//cast proc) (-> Text ///.Analysis) @@ -647,7 +653,7 @@ (do macro.Monad<Meta> [toT macro.expected-type to-name (check-jvm toT) - [valueT valueA] (&common.with-unknown-type + [valueT valueA] (typeA.with-inference (analyse valueC)) from-name (check-jvm valueT) can-cast? (: (Meta Bool) @@ -656,7 +662,7 @@ (^or [<primitive> <object>] [<object> <primitive>]) (do @ - [_ (&.infer (#.Primitive to-name (list)))] + [_ (typeA.infer (#.Primitive to-name (list)))] (wrap true))) (["boolean" "java.lang.Boolean"] ["byte" "java.lang.Byte"] @@ -669,22 +675,22 @@ _ (do @ - [_ (&.assert Primitives-Are-Not-Objects from-name - (not (dict.contains? from-name boxes))) - _ (&.assert Primitives-Are-Not-Objects to-name - (not (dict.contains? to-name boxes))) + [_ (lang.assert Primitives-Are-Not-Objects from-name + (not (dict.contains? from-name boxes))) + _ (lang.assert Primitives-Are-Not-Objects to-name + (not (dict.contains? to-name boxes))) to-class (load-class to-name)] (loop [[current-name currentT] [from-name valueT]] (if (text/= to-name current-name) (do @ - [_ (&.infer toT)] + [_ (typeA.infer toT)] (wrap true)) (do @ [current-class (load-class current-name) - _ (&.assert Cannot-Cast (format "From class/primitive: " current-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n") - (Class::isAssignableFrom [current-class] to-class)) + _ (lang.assert Cannot-Cast (format "From class/primitive: " current-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n") + (Class::isAssignableFrom [current-class] to-class)) candiate-parents (monad.map @ (function (_ java-type) (do @ @@ -703,32 +709,32 @@ (recur [next-name nextT])) #.Nil - (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n"))) + (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n"))) ))))))] (if can-cast? - (wrap (la.procedure proc (list (code.text from-name) - (code.text to-name) - valueA))) - (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n")))) + (wrap (#analysisL.Special proc (list (analysisL.text from-name) + (analysisL.text to-name) + valueA))) + (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) + (lang.throw /.invalid-syntax [proc args])))) (def: object-procs - @.Bundle - (<| (@.prefix "object") + /.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?) - (@.install "cast" object//cast) + (/.install "null" object//null) + (/.install "null?" object//null?) + (/.install "synchronized" object//synchronized) + (/.install "throw" object//throw) + (/.install "class" object//class) + (/.install "instance?" object//instance?) + (/.install "cast" object//cast) ))) (def: (find-field class-name field-name) @@ -740,13 +746,13 @@ (let [owner (Field::getDeclaringClass [] field)] (if (is? owner class) (wrap [class field]) - (&.throw Mistaken-Field-Owner - (format " Field: " field-name "\n" - " Owner Class: " (Class::getName [] owner) "\n" - "Target Class: " class-name "\n")))) + (lang.throw Mistaken-Field-Owner + (format " Field: " field-name "\n" + " Owner Class: " (Class::getName [] owner) "\n" + "Target Class: " class-name "\n")))) (#e.Error _) - (&.throw Unknown-Field (format class-name "#" field-name))))) + (lang.throw Unknown-Field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Meta [Type Bool])) @@ -758,7 +764,7 @@ (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])]))) - (&.throw Not-Static-Field (format class-name "#" field-name))))) + (lang.throw Not-Static-Field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Meta [Type Bool])) @@ -778,20 +784,20 @@ (do @ [#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))] + _ (lang.assert Type-Parameter-Mismatch + (format "Expected: " (%i (.int num-params)) "\n" + " Actual: " (%i (.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>)))) _ - (&.throw Non-Object (%type objectT)))) + (lang.throw non-object objectT))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])])) - (&.throw Not-Virtual-Field (format class-name "#" field-name))))) + (lang.throw Not-Virtual-Field (format class-name "#" field-name))))) (def: (static//get proc) (-> Text ///.Analysis) @@ -802,13 +808,13 @@ [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> [[fieldT final?] (static-field class field)] - (wrap (la.procedure proc (list (code.text class) (code.text field))))) + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))) + (lang.throw /.invalid-syntax [proc args])) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) (def: (static//put proc) (-> Text ///.Analysis) @@ -818,19 +824,19 @@ (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> - [_ (&.infer Any) + [_ (typeA.infer Any) [fieldT final?] (static-field class field) - _ (&.assert Cannot-Set-Final-Field (format class "#" field) - (not final?)) - valueA (&.with-type fieldT + _ (lang.assert Cannot-Set-Final-Field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT (analyse valueC))] - (wrap (la.procedure proc (list (code.text class) (code.text field) valueA)))) + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA)))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))) + (lang.throw /.invalid-syntax [proc args])) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +3 (list.size args)])))) (def: (virtual//get proc) (-> Text ///.Analysis) @@ -840,16 +846,16 @@ (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> - [[objectT objectA] (&common.with-unknown-type + [[objectT objectA] (typeA.with-inference (analyse objectC)) [fieldT final?] (virtual-field class field objectT)] - (wrap (la.procedure proc (list (code.text class) (code.text field) objectA)))) + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) objectA)))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))) + (lang.throw /.invalid-syntax [proc args])) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +3 (list.size args)])))) (def: (virtual//put proc) (-> Text ///.Analysis) @@ -859,21 +865,21 @@ (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> - [[objectT objectA] (&common.with-unknown-type + [[objectT objectA] (typeA.with-inference (analyse objectC)) - _ (&.infer objectT) + _ (typeA.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (&.assert Cannot-Set-Final-Field (format class "#" field) - (not final?)) - valueA (&.with-type fieldT + _ (lang.assert Cannot-Set-Final-Field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT (analyse valueC))] - (wrap (la.procedure proc (list (code.text class) (code.text field) valueA objectA)))) + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))) + (lang.throw /.invalid-syntax [proc args])) _ - (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +4 (list.size args)))))) + (lang.throw /.incorrect-special-arity [proc +4 (list.size args)])))) (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Meta Text)) @@ -893,7 +899,7 @@ (wrap (format componentP "[]"))) ## else - (&.throw Cannot-Convert-To-Parameter (type-descriptor type)))) + (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type)))) (type: Method-Type #Static @@ -947,13 +953,13 @@ (def: idx-to-bound (-> Nat Type) - (|>> (n/* +2) n/inc #.Bound)) + (|>> (n/* +2) inc #.Bound)) (def: (type-vars amount offset) (-> Nat Nat (List Type)) (if (n/= +0 amount) (list) - (|> (list.n/range offset (|> amount n/dec (n/+ offset))) + (|> (list.n/range offset (|> amount dec (n/+ offset))) (list/map idx-to-bound)))) (def: (method-to-type method-type method) @@ -1016,13 +1022,13 @@ (wrap [passes? method])))))] (case (list.filter product.left candidates) #.Nil - (&.throw No-Candidates (format class-name "#" method-name)) + (lang.throw No-Candidates (format class-name "#" method-name)) (#.Cons candidate #.Nil) (|> candidate product.right (method-to-type method-type)) _ - (&.throw Too-Many-Candidates (format class-name "#" method-name))))) + (lang.throw Too-Many-Candidates (format class-name "#" method-name))))) (def: (constructor-to-type constructor) (-> (Constructor Object) (Meta [Type (List Type)])) @@ -1072,20 +1078,20 @@ (wrap [passes? constructor])))))] (case (list.filter product.left candidates) #.Nil - (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) + (lang.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) (#.Cons candidate #.Nil) (|> candidate product.right constructor-to-type) _ - (&.throw Too-Many-Candidates class-name)))) + (lang.throw Too-Many-Candidates class-name)))) (def: (decorate-inputs typesT inputsA) - (-> (List Text) (List la.Analysis) (List la.Analysis)) + (-> (List Text) (List Analysis) (List Analysis)) (|> inputsA - (list.zip2 (list/map code.text typesT)) + (list.zip2 (list/map analysisL.text typesT)) (list/map (function (_ [type value]) - (la.product (list type value)))))) + (analysisL.product-analysis (list type value)))))) (def: (invoke//static proc) (-> Text ///.Analysis) @@ -1098,11 +1104,11 @@ [methodT exceptionsT] (methods class method #Static argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) outputJC (check-jvm outputT)] - (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text outputJC) (decorate-inputs argsT argsA))))) + (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) + (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//virtual proc) (-> Text ///.Analysis) @@ -1121,11 +1127,11 @@ _ (undefined))] outputJC (check-jvm outputT)] - (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text outputJC) objectA (decorate-inputs argsT argsA))))) + (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) + (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//special proc) (-> Text ///.Analysis) @@ -1138,11 +1144,11 @@ [methodT exceptionsT] (methods class method #Special argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] - (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text outputJC) (decorate-inputs argsT argsA))))) + (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) + (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//interface proc) (-> Text ///.Analysis) @@ -1153,17 +1159,17 @@ (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)])) + _ (lang.assert non-interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (methods class-name method #Interface argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] - (wrap (la.procedure proc - (list& (code.text class-name) (code.text method) (code.text outputJC) - (decorate-inputs argsT argsA))))) + (wrap (#analysisL.Special proc + (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) + (decorate-inputs argsT argsA))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) + (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//constructor proc) (-> Text ///.Analysis) @@ -1175,36 +1181,36 @@ [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-methods class argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] - (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA))))) + (wrap (#analysisL.Special proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) + (lang.throw /.invalid-syntax [proc args])))) (def: member-procs - @.Bundle - (<| (@.prefix "member") + /.Bundle + (<| (/.prefix "member") (|> (dict.new text.Hash<Text>) - (dict.merge (<| (@.prefix "static") + (dict.merge (<| (/.prefix "static") (|> (dict.new text.Hash<Text>) - (@.install "get" static//get) - (@.install "put" static//put)))) - (dict.merge (<| (@.prefix "virtual") + (/.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") + (/.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) + (/.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") +(def: #export specials + /.Bundle + (<| (/.prefix "jvm") (|> (dict.new text.Hash<Text>) (dict.merge conversion-procs) (dict.merge int-procs) diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux index 80e6d4740..8d4fdf981 100644 --- a/stdlib/source/lux/lang/init.lux +++ b/stdlib/source/lux/lang/init.lux @@ -1,11 +1,11 @@ (.module: lux - ## (// [".L" extension] - ## (extension [".E" analysis] - ## [".E" synthesis] - ## [".E" translation] - ## [".E" statement])) - ) + (// [".L" extension] + (extension [".E" analysis] + ## [".E" synthesis] + ## [".E" translation] + ## [".E" statement] + ))) (def: #export (cursor file) (-> Text Cursor) @@ -30,7 +30,13 @@ (def: #export info Info {#.target (for {"JVM" "JVM" - "JS" "JS"}) + "JS" "JS" + "Lua" "Lua" + "Python" "Python" + "Ruby" "Ruby" + "PHP" "PHP" + "Scheme" "Scheme" + "Common Lisp" "Common Lisp"}) #.version ..version #.mode #.Build}) @@ -47,10 +53,9 @@ #.seed +0 #.scope-type-vars (list) #.extensions (:! Nothing - [] - ## {#extensionL.analysis analysisE.defaults - ## #extensionL.synthesis synthesisE.defaults - ## #extensionL.translation translationE.defaults - ## #extensionL.statement statementE.defaults} - ) + {#extensionL.analysis analysisE.defaults + #extensionL.synthesis (:!! []) ## synthesisE.defaults + #extensionL.translation (:!! []) ## translationE.defaults + #extensionL.statement (:!! []) ## statementE.defaults + }) #.host (:! Nothing host)}) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux index 33c8aa063..33c8aa063 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/stdlib/source/lux/lang/synthesis.lux diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/analysis/procedure/common.lux index fba355a79..898376045 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux +++ b/stdlib/test/test/lux/lang/analysis/procedure/common.lux @@ -11,25 +11,21 @@ ["r" math/random "r/" Monad<Random>] [macro #+ Monad<Meta>] (macro [code]) - (lang [type "type/" Eq<Type>]) + [lang] + (lang [type "type/" Eq<Type>] + [".L" scope] + [".L" init] + (analysis [".A" type])) test) - (luxc ["&" lang] - (lang ["&." scope] - ["&." module] - ["~" analysis] - (analysis [".A" expression] - ["@." common]) - [".L" eval])) - (/// common) - (test/luxc common)) + (/// ["_." primitive])) (do-template [<name> <success> <failure>] [(def: (<name> procedure params output-type) (-> Text (List Code) Type Bool) - (|> (&.with-scope - (&.with-type output-type - (analyse (` ((~ (code.text procedure)) (~+ params)))))) - (macro.run (io.run init-jvm)) + (|> (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) + (macro.run (initL.compiler [])) (case> (#e.Success _) <success> @@ -43,8 +39,8 @@ (context: "Lux procedures" (<| (times +100) (do @ - [[primT primC] gen-primitive - [antiT antiC] (|> gen-primitive + [[primT primC] _primitive.primitive + [antiT antiC] (|> _primitive.primitive (r.filter (|>> product.left (type/= primT) not)))] ($_ seq (test "Can test for reference equality." @@ -64,8 +60,6 @@ signedC (|> r.int (:: @ map code.int)) paramC (|> r.nat (:: @ map code.nat))] ($_ seq - (test "Can count the number of 1 bits in a bit pattern." - (check-success+ "lux bit count" (list subjectC) Nat)) (test "Can perform bit 'and'." (check-success+ "lux bit and" (list subjectC paramC) Nat)) (test "Can perform bit 'or'." @@ -117,7 +111,7 @@ (do @ [subjectC (|> r.frac (:: @ map code.frac)) paramC (|> r.frac (:: @ map code.frac)) - encodedC (|> (r.text +5) (:: @ map code.text))] + encodedC (|> (r.unicode +5) (:: @ map code.text))] ($_ seq (test "Can add frac numbers." (check-success+ "lux frac +" (list subjectC paramC) Frac)) @@ -156,9 +150,9 @@ (context: "Text procedures" (<| (times +100) (do @ - [subjectC (|> (r.text +5) (:: @ map code.text)) - paramC (|> (r.text +5) (:: @ map code.text)) - replacementC (|> (r.text +5) (:: @ map code.text)) + [subjectC (|> (r.unicode +5) (:: @ map code.text)) + paramC (|> (r.unicode +5) (:: @ map code.text)) + replacementC (|> (r.unicode +5) (:: @ map code.text)) fromC (|> r.nat (:: @ map code.nat)) toC (|> r.nat (:: @ map code.nat))] ($_ seq @@ -187,18 +181,18 @@ (context: "Array procedures" (<| (times +100) (do @ - [[elemT elemC] gen-primitive + [[elemT elemC] _primitive.primitive sizeC (|> r.nat (:: @ map code.nat)) idxC (|> r.nat (:: @ map code.nat)) - var-name (r.text +5) + var-name (r.unicode +5) #let [arrayT (type (Array elemT)) g!array (code.local-symbol var-name) array-operation (function (_ output-type code) - (|> (&scope.with-scope "" - (&scope.with-local [var-name arrayT] - (&.with-type output-type - (analyse code)))) - (macro.run (io.run init-jvm)) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name arrayT] + (typeA.with-type output-type + (_primitive.analyse code)))) + (macro.run (initL.compiler [])) (case> (#e.Success _) true @@ -226,65 +220,63 @@ (do @ [subjectC (|> r.frac (:: @ map code.frac)) paramC (|> r.frac (:: @ map code.frac))] - (with-expansions [<unary> (do-template [<proc> <desc>] - [(test (format "Can calculate " <desc> ".") - (check-success+ <proc> (list subjectC) Frac))] + (`` ($_ seq + (~~ (do-template [<proc> <desc>] + [(test (format "Can calculate " <desc> ".") + (check-success+ <proc> (list subjectC) Frac))] - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"]) - <binary> (do-template [<proc> <desc>] - [(test (format "Can calculate " <desc> ".") - (check-success+ <proc> (list subjectC paramC) Frac))] + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"])) + (~~ (do-template [<proc> <desc>] + [(test (format "Can calculate " <desc> ".") + (check-success+ <proc> (list subjectC paramC) Frac))] - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"])] - ($_ seq - <unary> - <binary>))))) + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"]))))))) (context: "Atom procedures" (<| (times +100) (do @ - [[elemT elemC] gen-primitive + [[elemT elemC] _primitive.primitive sizeC (|> r.nat (:: @ map code.nat)) idxC (|> r.nat (:: @ map code.nat)) - var-name (r.text +5) + var-name (r.unicode +5) #let [atomT (type (atom.Atom elemT))]] ($_ seq (test "Can create atomic reference." (check-success+ "lux atom new" (list elemC) atomT)) (test "Can read the value of an atomic reference." - (|> (&scope.with-scope "" - (&scope.with-local [var-name atomT] - (&.with-type elemT - (analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) - (macro.run (io.run init-jvm)) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type elemT + (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) + (macro.run (initL.compiler [])) (case> (#e.Success _) true (#e.Error _) false))) (test "Can swap the value of an atomic reference." - (|> (&scope.with-scope "" - (&scope.with-local [var-name atomT] - (&.with-type Bool - (analyse (` ("lux atom compare-and-swap" - (~ (code.symbol ["" var-name])) - (~ elemC) - (~ elemC))))))) - (macro.run (io.run init-jvm)) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type Bool + (_primitive.analyse (` ("lux atom compare-and-swap" + (~ (code.symbol ["" var-name])) + (~ elemC) + (~ elemC))))))) + (macro.run (initL.compiler [])) (case> (#e.Success _) true @@ -295,7 +287,7 @@ (context: "Process procedures" (<| (times +100) (do @ - [[primT primC] gen-primitive + [[primT primC] _primitive.primitive timeC (|> r.nat (:: @ map code.nat))] ($_ seq (test "Can query the level of concurrency." @@ -310,7 +302,7 @@ (context: "IO procedures" (<| (times +100) (do @ - [logC (|> (r.text +5) (:: @ map code.text)) + [logC (|> (r.unicode +5) (:: @ map code.text)) exitC (|> r.int (:: @ map code.int))] ($_ seq (test "Can log messages to standard output." diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux index 3d0c76777..0a60149d5 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux +++ b/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux @@ -15,31 +15,25 @@ ["r" math/random "r/" Monad<Random>] [macro #+ Monad<Meta>] (macro [code]) - (lang [type]) + [lang] + (lang [type] + [".L" init] + (analysis [".A" type]) + (extension (analysis [".AE" host]))) test) - (luxc ["&" lang] - (lang ["&." scope] - ["&." module] - ["~" analysis] - (analysis [".A" expression] - ["@." common]) - (translation (jvm ["@." runtime])) - (extension (analysis ["@." host])) - [".L" eval])) - (/// common) - (test/luxc common)) + (/// ["_." primitive])) (do-template [<name> <success> <failure>] [(def: (<name> procedure params output-type) (-> Text (List Code) Type Bool) (|> (do Monad<Meta> - [runtime-bytecode @runtime.translate] - (&.with-scope - (&.with-type output-type - ((expressionA.analyser evalL.eval) - (` ((~ (code.text procedure)) (~+ params))))))) - (&.with-current-module "") - (macro.run (io.run init-jvm)) + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) (case> (#e.Success _) <success> @@ -54,12 +48,13 @@ [(def: (<name> syntax output-type) (-> Code Type Bool) (|> (do Monad<Meta> - [runtime-bytecode @runtime.translate] - (&.with-scope - (&.with-type output-type - (expressionA.analyser evalL.eval syntax)))) - (&.with-current-module "") - (macro.run (io.run init-jvm)) + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse syntax)))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) (case> (#e.Success _) <success> @@ -77,12 +72,12 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["jvm convert double-to-float" "java.lang.Double" @host.Float] - ["jvm convert double-to-int" "java.lang.Double" @host.Integer] - ["jvm convert double-to-long" "java.lang.Double" @host.Long] - ["jvm convert float-to-double" "java.lang.Float" @host.Double] - ["jvm convert float-to-int" "java.lang.Float" @host.Integer] - ["jvm convert float-to-long" "java.lang.Float" @host.Long] + ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] + ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] + ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] + ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] + ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] + ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] )] ($_ seq <conversions> @@ -95,12 +90,12 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["jvm convert int-to-byte" "java.lang.Integer" @host.Byte] - ["jvm convert int-to-char" "java.lang.Integer" @host.Character] - ["jvm convert int-to-double" "java.lang.Integer" @host.Double] - ["jvm convert int-to-float" "java.lang.Integer" @host.Float] - ["jvm convert int-to-long" "java.lang.Integer" @host.Long] - ["jvm convert int-to-short" "java.lang.Integer" @host.Short] + ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] + ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] + ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] + ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] + ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] + ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] )] ($_ seq <conversions> @@ -113,11 +108,11 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["jvm convert long-to-double" "java.lang.Long" @host.Double] - ["jvm convert long-to-float" "java.lang.Long" @host.Float] - ["jvm convert long-to-int" "java.lang.Long" @host.Integer] - ["jvm convert long-to-short" "java.lang.Long" @host.Short] - ["jvm convert long-to-byte" "java.lang.Long" @host.Byte] + ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] + ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] + ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] + ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] + ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] )] ($_ seq <conversions> @@ -130,12 +125,12 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["jvm convert char-to-byte" "java.lang.Character" @host.Byte] - ["jvm convert char-to-short" "java.lang.Character" @host.Short] - ["jvm convert char-to-int" "java.lang.Character" @host.Integer] - ["jvm convert char-to-long" "java.lang.Character" @host.Long] - ["jvm convert byte-to-long" "java.lang.Byte" @host.Long] - ["jvm convert short-to-long" "java.lang.Short" @host.Long] + ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] + ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] + ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] + ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] + ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] + ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] )] ($_ seq <conversions> @@ -168,8 +163,8 @@ (' ("lux coerce" (+0 <param> (+0)) []))) <output>))] - [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] + [(format "jvm " <domain> " =") <boxed> <boxed> hostAE.Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> hostAE.Boolean] )] ($_ seq <instructions> @@ -195,8 +190,8 @@ )))] - ["int" "java.lang.Integer" @host.Integer] - ["long" "java.lang.Long" @host.Long] + ["int" "java.lang.Integer" hostAE.Integer] + ["long" "java.lang.Long" hostAE.Long] ) (do-template [<domain> <boxed> <type>] @@ -226,16 +221,16 @@ (' ("lux coerce" (+0 <param> (+0)) []))) <output>))] - [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] + [(format "jvm " <domain> " =") <boxed> <boxed> hostAE.Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> hostAE.Boolean] )] ($_ seq <instructions> )))] - ["float" "java.lang.Float" @host.Float] - ["double" "java.lang.Double" @host.Double] + ["float" "java.lang.Float" hostAE.Float] + ["double" "java.lang.Double" hostAE.Double] ) (do-template [<domain> <boxed> <type>] @@ -247,23 +242,23 @@ (' ("lux coerce" (+0 <param> (+0)) []))) <output>))] - [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] + [(format "jvm " <domain> " =") <boxed> <boxed> hostAE.Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> hostAE.Boolean] )] ($_ seq <instructions> )))] - ["char" "java.lang.Character" @host.Character] + ["char" "java.lang.Character" hostAE.Character] ) (def: array-type (r.Random [Text Text]) - (let [entries (dict.entries @host.boxes) + (let [entries (dict.entries hostAE.boxes) num-entries (list.size entries)] (do r.Monad<Random> - [choice (|> r.nat (:: @ map (n/% (n/inc num-entries)))) + [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) #let [[unboxed boxed] (: [Text Text] (|> entries (list.nth choice) @@ -340,7 +335,7 @@ unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) ("jvm object null")))] throwable (|> r.nat - (:: @ map (n/% (n/inc (list.size throwables)))) + (:: @ map (n/% (inc (list.size throwables)))) (:: @ map (function (_ idx) (|> throwables (list.nth idx) |