diff options
author | Eduardo Julian | 2018-08-11 19:46:17 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-08-11 19:46:17 -0400 |
commit | 425148d29846ba507599b220d4df05c805e8d38a (patch) | |
tree | 8181e4e295cce83c8ff193228acc83f18594cc1a | |
parent | 725bcd5670a5d83c201fac147aedce01d9283d03 (diff) |
Fixed various JVM translation tests.
14 files changed, 406 insertions, 485 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index 6f56f9e0e..cb5bb46fb 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -96,17 +96,16 @@ (type: #export Host (translation.Host Inst Definition)) -(type: #export State - (translation.State ..Anchor Inst Definition)) - -(type: #export Operation - (translation.Operation ..Anchor Inst Definition)) - -(type: #export Phase - (translation.Phase ..Anchor Inst Definition)) - -(type: #export Bundle - (translation.Bundle ..Anchor Inst Definition)) +(do-template [<name> <base>] + [(type: #export <name> + (<base> ..Anchor Inst Definition))] + + [State translation.State] + [Operation translation.Operation] + [Phase translation.Phase] + [Handler translation.Handler] + [Bundle translation.Bundle] + ) ## [Values] (syntax: (config: {type s.local-identifier} diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 2aa46e050..f9b081972 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -214,3 +214,7 @@ (def: #export function-class "LuxFunction") (def: #export runnable-class "LuxRunnable") (def: #export unit "") + +(def: #export $Variant jvm.Type (type.array 1 ..$Object)) +(def: #export $Tuple jvm.Type (type.array 1 ..$Object)) +(def: #export $Function jvm.Type (type.class ..function-class (list))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index 809a13bb9..7ce1d6fda 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -1,180 +1,122 @@ (.module: - lux - (lux (control [monad #+ do] - ["p" parser] - ["ex" exception #+ exception:]) - (data ["e" error] - [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host] - ["//" lang] - (lang ["//." reference #+ Register] - ["//." synthesis #+ Synthesis] - ["//." extension])) - (luxc (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["_" inst])))) - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -(host.import: java/lang/Double + [lux #* + [control + ["." monad (#+ do)] + ["p" parser] + ["ex" exception (#+ exception:)]] + [data + ["." text + format] + [collection + ["." list ("list/." Functor<List>)] + ["." dictionary]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [compiler + [default + ["." phase + [synthesis (#+ Synthesis)] + ["." extension + ["." bundle]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Method Handler Bundle) + ["_t" type] + ["_" inst]]]]] + ["." /// + ["." runtime]]) + +(import: java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE Double)) ## [Types] -(type: #export Translator - (-> Synthesis (Meta $.Inst))) - -(type: #export Proc - (-> Translator (List Synthesis) (Meta $.Inst))) - -(type: #export Bundle - (Dict Text Proc)) - (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: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash<Text>))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .int %i) "\n" - " Actual: " (|> actual .int %i))) +(def: $Object-Array $.Type (_t.array 1 ///.$Object)) +(def: $String $.Type (_t.class "java.lang.String" (list))) +(def: $CharSequence $.Type (_t.class "java.lang.CharSequence" (list))) (syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!proc g!name g!translate g!inputs] + (with-gensyms [g!_ g!extension g!extension-name g!phase g!inputs] (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad<Meta> - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do macro.Monad<Meta> - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) + [g!inputC+ (monad.seq @ (list.repeat arity (macro.gensym "input"))) + #let [arityC (code.nat arity)]] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ arityC) Inst) Inst) ..Handler) + (function ((~ g!_) (~ g!extension-name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!inputC+))) + (do phase.Monad<Operation> + [(~+ (|> g!inputC+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!inputC+)]))) + + (~ g!_) + (phase.fail (ex.construct extension.incorrect-arity + [(~ g!extension-name) (~ arityC) (list.size (~ g!inputs))]))))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name phase inputsS) + (do phase.Monad<Operation> + [inputsH (monad.map @ phase inputsS)] + (wrap (extension inputsH))))) ## [Instructions] -(def: lux-intI $.Inst (|>> _.I2L (_.wrap #$.Long))) -(def: jvm-intI $.Inst (|>> (_.unwrap #$.Long) _.L2I)) +(def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long))) +(def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I)) (def: (predicateI tester) - (-> (-> $.Label $.Inst) - $.Inst) + (-> (-> Label Inst) + Inst) (<| _.with-label (function (_ @then)) _.with-label (function (_ @end)) (|>> (tester @then) - (_.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + (_.GETSTATIC "java.lang.Boolean" "FALSE" (_t.class "java.lang.Boolean" (list))) (_.GOTO @end) (_.label @then) - (_.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + (_.GETSTATIC "java.lang.Boolean" "TRUE" (_t.class "java.lang.Boolean" (list))) (_.label @end) ))) -(def: unitI $.Inst (_.string hostL.unit)) +(def: unitI Inst (_.string ///.unit)) -## [Procedures] -## [[Lux]] -(def: (lux//is [leftI rightI]) +## Extensions +### Lux +(def: (lux::is [leftI rightI]) Binary (|>> leftI rightI (predicateI _.IF_ACMPEQ))) -(def: (lux//if [testI thenI elseI]) - Trinary - (caseT.translate-if testI thenI elseI)) - -(def: (lux//try riskyI) +(def: (lux::try riskyI) Unary (|>> riskyI - (_.CHECKCAST hostL.function-class) - (_.INVOKESTATIC hostL.runtime-class "try" - ($t.method (list $Function) (#.Some $Object-Array) (list)) + (_.CHECKCAST ///.function-class) + (_.INVOKESTATIC ///.runtime-class "try" + (_t.method (list ///.$Function) (#.Some $Object-Array) (list)) #0))) -(exception: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (wrong-syntax procedure args) - (-> Text (List Synthesis) Text) - (format "Procedure: " procedure "\n" - "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) - - (#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)))) - -## [[Bits]] +### Bits (do-template [<name> <op>] [(def: (<name> [inputI maskI]) Binary @@ -182,9 +124,9 @@ maskI (_.unwrap #$.Long) <op> (_.wrap #$.Long)))] - [bit//and _.LAND] - [bit//or _.LOR] - [bit//xor _.LXOR] + [bit::and _.LAND] + [bit::or _.LOR] + [bit::xor _.LXOR] ) (do-template [<name> <op>] @@ -195,24 +137,20 @@ <op> (_.wrap #$.Long)))] - [bit//left-shift _.LSHL] - [bit//arithmetic-right-shift _.LSHR] - [bit//logical-right-shift _.LUSHR] + [bit::left-shift _.LSHL] + [bit::arithmetic-right-shift _.LSHR] + [bit::logical-right-shift _.LUSHR] ) -## [[Numbers]] -(def: nat-method - $.Method - ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) - +### Numbers (do-template [<name> <const> <type>] [(def: (<name> _) Nullary (|>> <const> (_.wrap <type>)))] - [frac//smallest (_.double Double::MIN_VALUE) #$.Double] - [frac//min (_.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] - [frac//max (_.double Double::MAX_VALUE) #$.Double] + [f64::smallest (_.double Double::MIN_VALUE) #$.Double] + [f64::min (_.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] + [f64::max (_.double Double::MAX_VALUE) #$.Double] ) (do-template [<name> <type> <op>] @@ -223,17 +161,17 @@ <op> (_.wrap <type>)))] - [int//add #$.Long _.LADD] - [int//sub #$.Long _.LSUB] - [int//mul #$.Long _.LMUL] - [int//div #$.Long _.LDIV] - [int//rem #$.Long _.LREM] + [i64::add #$.Long _.LADD] + [i64::sub #$.Long _.LSUB] + [i64::mul #$.Long _.LMUL] + [i64::div #$.Long _.LDIV] + [i64::rem #$.Long _.LREM] - [frac//add #$.Double _.DADD] - [frac//sub #$.Double _.DSUB] - [frac//mul #$.Double _.DMUL] - [frac//div #$.Double _.DDIV] - [frac//rem #$.Double _.DREM] + [f64::add #$.Double _.DADD] + [f64::sub #$.Double _.DSUB] + [f64::mul #$.Double _.DMUL] + [f64::div #$.Double _.DDIV] + [f64::rem #$.Double _.DREM] ) (do-template [<eq> <lt> <unwrap> <cmp>] @@ -245,11 +183,11 @@ <cmp> (_.int <reference>) (predicateI _.IF_ICMPEQ)))] - [<eq> 0] + [<eq> +0] [<lt> -1])] - [int//eq int//lt (_.unwrap #$.Long) _.LCMP] - [frac//eq frac//lt (_.unwrap #$.Double) _.DCMPG] + [i64::eq i64::lt (_.unwrap #$.Long) _.LCMP] + [f64::eq f64::lt (_.unwrap #$.Double) _.DCMPG] ) (do-template [<name> <prepare> <transform>] @@ -257,28 +195,24 @@ Unary (|>> inputI <prepare> <transform>))] - [int//to-frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)] - [int//char (_.unwrap #$.Long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) #0)))] + [i64::to-f64 (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)] + [i64::char (_.unwrap #$.Long) + ((|>> _.L2I _.I2C (_.INVOKESTATIC "java.lang.Character" "toString" (_t.method (list _t.char) (#.Some $String) (list)) #0)))] - [frac//to-int (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)] - [frac//encode (_.unwrap #$.Double) - (_.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) #0)] - [frac//decode (_.CHECKCAST "java.lang.String") - (_.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) #0)] + [f64::to-i64 (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)] + [f64::encode (_.unwrap #$.Double) + (_.INVOKESTATIC "java.lang.Double" "toString" (_t.method (list _t.double) (#.Some $String) (list)) #0)] + [f64::decode (_.CHECKCAST "java.lang.String") + (_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)] ) -## [[Text]] -(do-template [<name> <class> <method> <post> <outputT>] - [(def: (<name> inputI) - Unary - (|>> inputI - (_.CHECKCAST "java.lang.String") - (_.INVOKEVIRTUAL <class> <method> ($t.method (list) (#.Some <outputT>) (list)) #0) - <post>))] - - [text//size "java.lang.String" "length" lux-intI $t.int] - ) +### Text +(def: (text::size inputI) + Unary + (|>> inputI + (_.CHECKCAST "java.lang.String") + (_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0) + lux-intI)) (do-template [<name> <pre-subject> <pre-param> <op> <post>] [(def: (<name> [subjectI paramI]) @@ -287,17 +221,17 @@ paramI <pre-param> <op> <post>))] - [text//eq id id - (_.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) #0) + [text::eq id id + (_.INVOKEVIRTUAL "java.lang.Object" "equals" (_t.method (list ///.$Object) (#.Some _t.boolean) (list)) #0) (_.wrap #$.Boolean)] - [text//lt (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") - (_.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) #0) + [text::lt (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") + (_.INVOKEVIRTUAL "java.lang.String" "compareTo" (_t.method (list $String) (#.Some _t.int) (list)) #0) (<| (predicateI _.IF_ICMPEQ) (_.int -1))] - [text//concat (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") - (_.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0) + [text::concat (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") + (_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0) id] - [text//char (_.CHECKCAST "java.lang.String") jvm-intI - (_.INVOKESTATIC hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) #0) + [text::char (_.CHECKCAST "java.lang.String") jvm-intI + (_.INVOKESTATIC ///.runtime-class "text_char" (_t.method (list $String _t.int) (#.Some ///.$Variant) (list)) #0) id] ) @@ -309,13 +243,13 @@ extraI <pre-extra> <op>))] - [text//clip (_.CHECKCAST "java.lang.String") jvm-intI jvm-intI - (_.INVOKESTATIC hostL.runtime-class "text_clip" - ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) #0)] + [text::clip (_.CHECKCAST "java.lang.String") jvm-intI jvm-intI + (_.INVOKESTATIC ///.runtime-class "text_clip" + (_t.method (list $String _t.int _t.int) (#.Some ///.$Variant) (list)) #0)] ) -(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) -(def: (text//index [textI partI startI]) +(def: index-method Method (_t.method (list $String _t.int) (#.Some _t.int) (list))) +(def: (text::index [textI partI startI]) Trinary (<| _.with-label (function (_ @not-found)) _.with-label (function (_ @end)) @@ -327,24 +261,24 @@ (_.int -1) (_.IF_ICMPEQ @not-found) lux-intI - runtimeT.someI + runtime.someI (_.GOTO @end) (_.label @not-found) - _.POP - runtimeT.noneI + ## _.POP + runtime.noneI (_.label @end)))) -## [[IO]] -(def: string-method $.Method ($t.method (list $String) #.None (list))) -(def: (io//log messageI) +### I/O +(def: string-method Method (_t.method (list $String) #.None (list))) +(def: (io::log messageI) Unary - (|>> (_.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) + (|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list))) messageI (_.CHECKCAST "java.lang.String") (_.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0) unitI)) -(def: (io//error messageI) +(def: (io::error messageI) Unary (|>> (_.NEW "java.lang.Error") _.DUP @@ -353,101 +287,94 @@ (_.INVOKESPECIAL "java.lang.Error" "<init>" string-method #0) _.ATHROW)) -(def: (io//exit codeI) +(def: (io::exit codeI) Unary (|>> codeI jvm-intI - (_.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) #0) + (_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0) _.NULL)) -(def: (io//current-time []) +(def: (io::current-time []) Nullary - (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) #0) + (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0) (_.wrap #$.Long))) -## [Bundles] -(def: lux-procs +## Bundles +(def: bundle::lux Bundle - (|> (dict.new text.Hash<Text>) - (install "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -(def: bit-procs + (|> (: Bundle bundle.empty) + (bundle.install "is" (binary lux::is)) + (bundle.install "try" (unary lux::try)))) + +(def: bundle::bit Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -(def: int-procs + (<| (bundle.prefix "bit") + (|> (: Bundle bundle.empty) + (bundle.install "and" (binary bit::and)) + (bundle.install "or" (binary bit::or)) + (bundle.install "xor" (binary bit::xor)) + (bundle.install "left-shift" (binary bit::left-shift)) + (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift))))) + +(def: bundle::i64 Bundle - (<| (prefix "int") - (|> (dict.new text.Hash<Text>) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//eq)) - (install "<" (binary int//lt)) - (install "to-frac" (unary int//to-frac)) - (install "char" (unary int//char))))) - -(def: frac-procs + (<| (bundle.prefix "i64") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary i64::add)) + (bundle.install "-" (binary i64::sub)) + (bundle.install "*" (binary i64::mul)) + (bundle.install "/" (binary i64::div)) + (bundle.install "%" (binary i64::rem)) + (bundle.install "=" (binary i64::eq)) + (bundle.install "<" (binary i64::lt)) + (bundle.install "to-f64" (unary i64::to-f64)) + (bundle.install "char" (unary i64::char))))) + +(def: bundle::f64 Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash<Text>) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (install "=" (binary frac//eq)) - (install "<" (binary frac//lt)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "to-int" (unary frac//to-int)) - (install "encode" (unary frac//encode)) - (install "decode" (unary frac//decode))))) - -(def: text-procs + (<| (bundle.prefix "f64") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary f64::add)) + (bundle.install "-" (binary f64::sub)) + (bundle.install "*" (binary f64::mul)) + (bundle.install "/" (binary f64::div)) + (bundle.install "%" (binary f64::rem)) + (bundle.install "=" (binary f64::eq)) + (bundle.install "<" (binary f64::lt)) + (bundle.install "smallest" (nullary f64::smallest)) + (bundle.install "min" (nullary f64::min)) + (bundle.install "max" (nullary f64::max)) + (bundle.install "to-i64" (unary f64::to-i64)) + (bundle.install "encode" (unary f64::encode)) + (bundle.install "decode" (unary f64::decode))))) + +(def: bundle::text Bundle - (<| (prefix "text") - (|> (dict.new text.Hash<Text>) - (install "=" (binary text//eq)) - (install "<" (binary text//lt)) - (install "concat" (binary text//concat)) - (install "index" (trinary text//index)) - (install "size" (unary text//size)) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - ))) - -(def: io-procs + (<| (bundle.prefix "text") + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary text::eq)) + (bundle.install "<" (binary text::lt)) + (bundle.install "concat" (binary text::concat)) + (bundle.install "index" (trinary text::index)) + (bundle.install "size" (unary text::size)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: bundle::io Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary io//log)) - (install "error" (unary io//error)) - (install "exit" (unary io//exit)) - (install "current-time" (nullary io//current-time))))) - -(def: #export procedures + (<| (bundle.prefix "io") + (|> (: Bundle bundle.empty) + (bundle.install "log" (unary io::log)) + (bundle.install "error" (unary io::error)) + (bundle.install "exit" (unary io::exit)) + (bundle.install "current-time" (nullary io::current-time))))) + +(def: #export bundle Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge io-procs) - ))) + (<| (bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge bundle::bit) + (dictionary.merge bundle::i64) + (dictionary.merge bundle::f64) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io)))) diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux index 7b370ab21..f694d81bd 100644 --- a/new-luxc/test/test/luxc/common.lux +++ b/new-luxc/test/test/luxc/common.lux @@ -5,15 +5,10 @@ ["." io (#+ IO)] [data [error (#+ Error)]] - ["." macro - ["." code]] [compiler - ["." default + [default ["." reference] - ["." init] ["." phase - ["." analysis - ["." module]] ["." synthesis (#+ Synthesis)] ["." translation] [extension @@ -26,40 +21,32 @@ ["." jvm ["._jvm" runtime] ["._jvm" expression] - ## ["._jvm" statement] - ] + [procedure + ["._jvm" common]]] ## [js] ## (js ["._js" expression] - ## ["._js" runtime] - ## ["._js" statement]) + ## ["._js" runtime]) ## [lua] ## (lua ["._lua" expression] - ## ["._lua" runtime] - ## ["._lua" statement]) + ## ["._lua" runtime]) ## [ruby] ## (ruby ["._ruby" expression] - ## ["._ruby" runtime] - ## ["._ruby" statement]) + ## ["._ruby" runtime]) ## [python] ## (python ["._python" expression] - ## ["._python" runtime] - ## ["._python" statement]) + ## ["._python" runtime]) ## [r] ## (r ["._r" expression] - ## ["._r" runtime] - ## ["._r" statement]) + ## ["._r" runtime]) ## [scheme] ## (scheme ["._scheme" expression] - ## ["._scheme" runtime] - ## ["._scheme" statement]) + ## ["._scheme" runtime]) ## [common-lisp] ## (common-lisp ["._common-lisp" expression] - ## ["._common-lisp" runtime] - ## ["._common-lisp" statement]) + ## ["._common-lisp" runtime]) ## [php] ## (php ["._php" expression] - ## ["._php" runtime] - ## ["._php" statement]) + ## ["._php" runtime]) ]]]) (type: #export Runner (-> Synthesis (Error Any))) @@ -84,26 +71,29 @@ (def: (runner generate-runtime translate bundle state) (-> (Operation Any) Phase Bundle (IO State) Runner) - (function (_ synthesis) + (function (_ valueS) (|> (do phase.Monad<Operation> [_ generate-runtime - program (translate synthesis)] - (translation.evaluate! program)) + program (translate valueS)] + (translation.evaluate! "runner" program)) + translation.with-buffer (phase.run [bundle (io.run state)])))) (def: (definer generate-runtime translate bundle state) (-> (Operation Any) Phase Bundle (IO State) Definer) - (function (_ name synthesis) + (function (_ lux-name valueS) (|> (do phase.Monad<Operation> [_ generate-runtime - valueS (translate synthesis) - _ (translation.define! name valueS) - program (translate (synthesis.constant name))] - (translation.evaluate! program)) + valueH (translate valueS) + [host-name host-value] (translation.define! lux-name valueH) + _ (translation.learn lux-name host-name) + program (translate (synthesis.constant lux-name))] + (translation.evaluate! "definer" program)) + translation.with-buffer (phase.run [bundle (io.run state)])))) -(def: #export run-jvm (runner runtime_jvm.translate expression_jvm.translate bundle.empty init-jvm)) -(def: #export def-jvm (definer runtime_jvm.translate expression_jvm.translate bundle.empty init-jvm)) +(def: #export run-jvm (runner runtime_jvm.translate expression_jvm.translate common_jvm.bundle init-jvm)) +(def: #export def-jvm (definer runtime_jvm.translate expression_jvm.translate common_jvm.bundle init-jvm)) ## (def: #export run-js (runner runtime_js.translate expression_js.translate bundle.empty init-js)) ## (def: #export def-js (definer runtime_js.translate expression_js.translate bundle.empty init-js)) diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux index f03965de2..246598072 100644 --- a/new-luxc/test/test/luxc/lang/translation/common.lux +++ b/new-luxc/test/test/luxc/lang/translation/common.lux @@ -4,7 +4,7 @@ [monad (#+ do)] pipe] [data - ["e" error] + ["." error (#+ Error)] [bit ("bit/." Equivalence<Bit>)] [number ("frac/." Number<Frac> Interval<Frac>) ["." i64]] @@ -33,10 +33,10 @@ [(test <name> (|> (run (#synthesis.Extension <name> (list (synthesis.i64 subject) (synthesis.i64 param)))) - (case> (#e.Success valueT) + (case> (#error.Success valueT) (n/= (<reference> param subject) (:coerce Nat valueT)) - (#e.Error error) + (#error.Error error) (exec (log! error) #0)) (let [param <param-expr>])))] @@ -53,12 +53,12 @@ (|> (run (#synthesis.Extension "lux bit arithmetic-right-shift" (list (synthesis.i64 subject) (synthesis.i64 param)))) - (case> (#e.Success valueT) + (case> (#error.Success valueT) ("lux i64 =" (i64.arithmetic-right-shift param subject) (:coerce I64 valueT)) - (#e.Error error) + (#error.Error error) (exec (log! error) #0)) (let [param (n/% 64 param)]))) @@ -73,31 +73,30 @@ (~~ (do-template [<name> <type> <prepare> <comp> <subject-expr>] [(test <name> (|> (run (#synthesis.Extension <name> (list (synthesis.i64 subject)))) - (case> (#e.Success valueT) + (case> (#error.Success valueT) (<comp> (<prepare> subject) (:coerce <type> valueT)) - (#e.Error error) + (#error.Error error) (exec (log! error) #0)) (let [subject <subject-expr>])))] - ["lux i64 to-frac" Frac int-to-frac f/= subject] - ["lux i64 char" Text (|>> (:coerce Nat) text.from-code) text/= (|> subject - (:coerce Nat) - (n/% (i64.left-shift 8 1)) - (:coerce Int))] + ["lux i64 to-f64" Frac int-to-frac f/= subject] + ["lux i64 char" Text (|>> (:coerce Nat) text.from-code) text/= (|> subject + (:coerce Nat) + (n/% (i64.left-shift 8 1)) + (:coerce Int))] )) (~~ (do-template [<name> <reference> <outputT> <comp>] [(test <name> - (exec (log! <name>) - (|> (run (#synthesis.Extension <name> (list (synthesis.i64 subject) - (synthesis.i64 param)))) - (case> (#e.Success valueT) - (<comp> (<reference> param subject) (:coerce <outputT> valueT)) + (|> (run (#synthesis.Extension <name> (list (synthesis.i64 subject) + (synthesis.i64 param)))) + (case> (#error.Success valueT) + (<comp> (<reference> param subject) (:coerce <outputT> valueT)) - (#e.Error error) - (exec (log! error) - #0)))))] + (#error.Error error) + (exec (log! error) + #0))))] ["lux i64 +" i/+ Int i/=] ["lux i64 -" i/- Int i/=] @@ -118,7 +117,7 @@ [(test <name> (|> (run (#synthesis.Extension <name> (list (synthesis.f64 subject) (synthesis.f64 param)))) - (case> (#e.Success valueT) + (case> (#error.Success valueT) (<comp> (<reference> param subject) (:coerce <outputT> valueT)) _ @@ -139,12 +138,12 @@ (def: (f64-spec/1 run) (-> Runner Test) (do r.Monad<Random> - [subject r.frac] + [subject (|> r.nat (:: @ map (|>> (n/% 1000) .int int-to-frac)))] (`` ($_ seq (~~ (do-template [<name> <test>] [(test <name> (|> (run (#synthesis.Extension <name> (list))) - (case> (#e.Success valueT) + (case> (#error.Success valueT) (<test> (:coerce Frac valueT)) _ @@ -154,19 +153,16 @@ ["lux f64 max" (f/= frac/top)] ["lux f64 smallest" (f/= ("lux frac smallest"))] )) - (~~ (do-template [<forward> <backward> <test>] - [(test <forward> - (|> (run (|> subject synthesis.f64 - (list) (#synthesis.Extension <forward>) - (list) (#synthesis.Extension <backward>))) - (case> (#e.Success valueT) - (|> valueT (:coerce Frac) (f/- subject) frac/abs <test>) - - (#e.Error error) - (exec (log! error) - #0))))] - - ["lux f64 to-int" "lux i64 to-frac" (f/< +1.0)])) + (test "\"lux f64 to-i64\" && \"lux i64 to-f64\"" + (|> (run (|> subject synthesis.f64 + (list) (#synthesis.Extension "lux f64 to-i64") + (list) (#synthesis.Extension "lux i64 to-f64"))) + (case> (#error.Success valueT) + (f/= subject (:coerce Frac valueT)) + + (#error.Error error) + (exec (log! error) + #0)))) )))) (def: (f64-spec run) @@ -195,34 +191,35 @@ ($_ seq (test "Can compare texts for equality." (and (|> (run (#synthesis.Extension "lux text =" (list sample0S sample0S))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) (:coerce Bit valueV) _ #0)) (|> (run (#synthesis.Extension "lux text =" (list sample0S sample1S))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) (not (:coerce Bit valueV)) _ #0)))) (test "Can compare texts for order." (|> (run (#synthesis.Extension "lux text <" (list sample1S sample0S))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) (:coerce Bit valueV) - _ - #0))) + (#error.Error error) + (exec (log! error) + #0)))) (test "Can get length of text." (|> (run (#synthesis.Extension "lux text size" (list sample0S))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) (n/= sample-size (:coerce Nat valueV)) _ #0))) (test "Can concatenate text." (|> (run (#synthesis.Extension "lux text size" (list concatenatedS))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) (n/= (n/* 2 sample-size) (:coerce Nat valueV)) _ @@ -230,8 +227,8 @@ (test "Can find index of sub-text." (and (|> (run (#synthesis.Extension "lux text index" (list concatenatedS sample0S - (synthesis.i64 0)))) - (case> (^multi (#e.Success valueV) + (synthesis.i64 +0)))) + (case> (^multi (#error.Success valueV) [(:coerce (Maybe Nat) valueV) (#.Some valueV)]) (n/= 0 valueV) @@ -239,8 +236,8 @@ #0)) (|> (run (#synthesis.Extension "lux text index" (list concatenatedS sample1S - (synthesis.i64 0)))) - (case> (^multi (#e.Success valueV) + (synthesis.i64 +0)))) + (case> (^multi (#error.Success valueV) [(:coerce (Maybe Nat) valueV) (#.Some valueV)]) (n/= sample-size valueV) @@ -252,7 +249,7 @@ (list concatenatedS (synthesis.i64 from) (synthesis.i64 to)))) - (case> (^multi (#e.Success valueV) + (case> (^multi (#error.Success valueV) [(:coerce (Maybe Text) valueV) (#.Some valueV)]) (text/= expected valueV) @@ -265,7 +262,7 @@ (|> (run (#synthesis.Extension "lux text char" (list sample0S (synthesis.i64 char-idx)))) - (case> (^multi (#e.Success valueV) + (case> (^multi (#error.Success valueV) [(:coerce (Maybe Int) valueV) (#.Some valueV)]) (text.contains? ("lux int char" valueV) sample0) @@ -282,10 +279,10 @@ (test "Can log messages." (|> (run (#synthesis.Extension "lux io log" (list (synthesis.text (format "LOG: " message))))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) #1 - (#e.Error error) + (#error.Error error) (exec (log! error) #0)))) (test "Can throw runtime errors." @@ -295,8 +292,8 @@ #synthesis.arity 1 #synthesis.body (#synthesis.Extension "lux io error" (list (synthesis.text message)))})))) - (case> (^multi (#e.Success valueV) - [(:coerce (e.Error Text) valueV) (#e.Error error)]) + (case> (^multi (#error.Success valueV) + [(:coerce (Error Text) valueV) (#error.Error error)]) (text.contains? message error) _ @@ -305,10 +302,9 @@ (list (synthesis.function/abstraction {#synthesis.environment (list) #synthesis.arity 1 - #synthesis.body (#synthesis.Extension "lux io error" - (list (synthesis.text message)))})))) - (case> (^multi (#e.Success valueV) - [(:coerce (e.Error Text) valueV) (#e.Success valueV)]) + #synthesis.body (synthesis.text message)})))) + (case> (^multi (#error.Success valueV) + [(:coerce (Error Text) valueV) (#error.Success valueV)]) (text/= message valueV) _ @@ -316,11 +312,11 @@ (test "Can obtain current time in milli-seconds." (|> (run (synthesis.tuple (list (#synthesis.Extension "lux io current-time" (list)) (#synthesis.Extension "lux io current-time" (list))))) - (case> (#e.Success valueV) + (case> (#error.Success valueV) (let [[pre post] (:coerce [Nat Nat] valueV)] (n/>= pre post)) - (#e.Error error) + (#error.Error error) (exec (log! error) #0)))) ))) diff --git a/new-luxc/test/test/luxc/lang/translation/primitive.lux b/new-luxc/test/test/luxc/lang/translation/primitive.lux index 08fab78aa..ee8e53d5e 100644 --- a/new-luxc/test/test/luxc/lang/translation/primitive.lux +++ b/new-luxc/test/test/luxc/lang/translation/primitive.lux @@ -6,6 +6,7 @@ [data ["." error] [bit ("bit/." Equivalence<Bit>)] + ["." number] [text ("text/." Equivalence<Text>) format]] [math @@ -19,6 +20,12 @@ [luxc common]]) +(def: (f/=' reference subject) + (-> Frac Frac Bit) + (or (f/= reference subject) + (and (number.not-a-number? reference) + (number.not-a-number? subject)))) + (def: (spec run) (-> Runner Test) (do r.Monad<Random> @@ -38,13 +45,13 @@ ["bit" Bit synthesis.bit |bit| bit/=] ["int" Int synthesis.i64 |i64| i/=] - ["frac" Frac synthesis.f64 |f64| f/=] - ["text" Text synthesis.text |text| text/=])) + ["frac" Frac synthesis.f64 |f64| f/='] + ["text" Text synthesis.text |text| text/=] + )) )))) (context: "[JVM] Primitives." - (<| (seed 7147645721729046766) - ## (times 100) + (<| (times 100) (spec run-jvm))) ## (context: "[JS] Primitives." diff --git a/new-luxc/test/test/luxc/lang/translation/reference.lux b/new-luxc/test/test/luxc/lang/translation/reference.lux index a10e98ae6..c1a348f76 100644 --- a/new-luxc/test/test/luxc/lang/translation/reference.lux +++ b/new-luxc/test/test/luxc/lang/translation/reference.lux @@ -20,14 +20,15 @@ [// ["&" function]]) -(def: name-part - (r.Random Text) - (r.ascii/alpha 5)) +(def: name^ + (r.Random Name) + (let [name-part (r.ascii/upper-alpha 5)] + [(r.and name-part name-part)])) (def: (definitions-spec define) (-> Definer Test) (do r.Monad<Random> - [name (r.and name-part name-part) + [name name^ value r.frac] (test "Can refer to definitions." (|> (define name (synthesis.f64 value)) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 09b95c6b2..04362d4d1 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -1,17 +1,17 @@ (.module: [lux [cli (#+ program:)] - [test]] + ["." test]] [test [luxc [lang [translation ["_.T" primitive] - ## ["_.T" structure] - ## ["_.T" function] - ## ["_.T" reference] - ## ["_.T" case] - ## ["_.T" common] + ["_.T" structure] + ["_.T" function] + ["_.T" reference] + ["_.T" case] + ["_.T" common] ## ["_.T" jvm] ## ["_.T" js] ## ["_.T" lua] diff --git a/stdlib/source/lux/compiler/default/phase/extension.lux b/stdlib/source/lux/compiler/default/phase/extension.lux index 808c6b4fd..56e8560f0 100644 --- a/stdlib/source/lux/compiler/default/phase/extension.lux +++ b/stdlib/source/lux/compiler/default/phase/extension.lux @@ -5,9 +5,10 @@ ["ex" exception (#+ exception:)]] [data ["." error (#+ Error)] - ["." text] + ["." text + format] [collection - ["dict" dictionary (#+ Dictionary)]]] + ["." dictionary (#+ Dictionary)]]] ["." function]] ["." //]) @@ -35,26 +36,32 @@ (do-template [<name>] [(exception: #export (<name> {name Text}) - (ex.report ["Name" name]))] + (ex.report ["Extension" (%t name)]))] [unknown] [cannot-overwrite] + [invalid-syntax] ) +(exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) + (ex.report ["Extension" (%t name)] + ["Expected" (%n arity)] + ["Actual" (%n args)])) + (def: #export (install name handler) (All [s i o] (-> Text (Handler s i o) (Operation s i o Any))) (function (_ [bundle state]) - (if (dict.contains? name bundle) + (if (dictionary.contains? name bundle) (ex.throw cannot-overwrite name) - (#error.Success [[(dict.put name handler bundle) state] + (#error.Success [[(dictionary.put name handler bundle) state] []])))) (def: #export (apply phase [name parameters]) (All [s i o] (-> (Phase s i o) (Extension i) (Operation s i o o))) (function (_ (^@ stateE [bundle state])) - (case (dict.get name bundle) + (case (dictionary.get name bundle) #.None (ex.throw unknown name) diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux index 59a99800b..65fcf8550 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux @@ -37,7 +37,7 @@ (analyse argC))) (list.zip2 inputsT+ args))] (wrap (#analysis.Extension extension-name argsA))) - (////.throw bundle.incorrect-arity [extension-name num-expected num-actual])))))) + (////.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) (def: #export (nullary valueT) (-> Type Handler) @@ -80,7 +80,7 @@ (wrap (#analysis.Extension extension-name (list opA)))) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: lux::in-module Handler @@ -91,7 +91,7 @@ (analyse exprC)) _ - (////.throw bundle.invalid-syntax [extension-name])))) + (////.throw ///.invalid-syntax [extension-name])))) (do-template [<name> <type>] [(def: (<name> eval) @@ -108,7 +108,7 @@ (analyse valueC))) _ - (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)]))))] + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] [lux::check actualT] [lux::coerce Any] @@ -126,7 +126,7 @@ (wrap valueA)) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (bundle::lux eval) (-> Eval Bundle) diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux index 5ba07b362..069ec4e1a 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux @@ -231,7 +231,7 @@ (wrap (#analysis.Extension extension-name (list arrayA)))) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: array::new Handler @@ -270,7 +270,7 @@ lengthA)))) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (check-jvm objectT) (-> Type (Operation Text)) @@ -344,7 +344,7 @@ (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA)))) _ - (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: array::write Handler @@ -366,7 +366,7 @@ (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA)))) _ - (////.throw bundle.incorrect-arity [extension-name 3 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: bundle::array Bundle @@ -389,7 +389,7 @@ (wrap (#analysis.Extension extension-name (list)))) _ - (////.throw bundle.incorrect-arity [extension-name 0 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) (def: object::null? Handler @@ -404,7 +404,7 @@ (wrap (#analysis.Extension extension-name (list objectA)))) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: object::synchronized Handler @@ -419,7 +419,7 @@ (wrap (#analysis.Extension extension-name (list monitorA exprA)))) _ - (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (host.import: java/lang/Object (equals [Object] boolean)) @@ -516,7 +516,7 @@ (wrap (#analysis.Extension extension-name (list exceptionA)))) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: object::class Handler @@ -531,10 +531,10 @@ (wrap (#analysis.Extension extension-name (list (analysis.text class))))) _ - (////.throw bundle.invalid-syntax extension-name)) + (////.throw ///.invalid-syntax extension-name)) _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: object::instance? Handler @@ -554,10 +554,10 @@ (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) _ - (////.throw bundle.invalid-syntax extension-name)) + (////.throw ///.invalid-syntax extension-name)) _ - (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: (java-type-to-class jvm-type) (-> java/lang/reflect/Type (Operation Text)) @@ -739,7 +739,7 @@ " For value: " (%code valueC) "\n")))) _ - (////.throw bundle.invalid-syntax extension-name)))) + (////.throw ///.invalid-syntax extension-name)))) (def: bundle::object Bundle @@ -828,10 +828,10 @@ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) _ - (////.throw bundle.invalid-syntax extension-name)) + (////.throw ///.invalid-syntax extension-name)) _ - (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: static::put Handler @@ -850,10 +850,10 @@ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA)))) _ - (////.throw bundle.invalid-syntax extension-name)) + (////.throw ///.invalid-syntax extension-name)) _ - (////.throw bundle.incorrect-arity [extension-name 3 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: virtual::get Handler @@ -869,10 +869,10 @@ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA)))) _ - (////.throw bundle.invalid-syntax extension-name)) + (////.throw ///.invalid-syntax extension-name)) _ - (////.throw bundle.incorrect-arity [extension-name 3 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: virtual::put Handler @@ -893,10 +893,10 @@ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA)))) _ - (////.throw bundle.invalid-syntax extension-name)) + (////.throw ///.invalid-syntax extension-name)) _ - (////.throw bundle.incorrect-arity [extension-name 4 (list.size args)])))) + (////.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Operation Text)) @@ -1155,7 +1155,7 @@ (analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (////.throw bundle.invalid-syntax extension-name)))) + (////.throw ///.invalid-syntax extension-name)))) (def: invoke::virtual Handler @@ -1178,7 +1178,7 @@ (analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) _ - (////.throw bundle.invalid-syntax extension-name)))) + (////.throw ///.invalid-syntax extension-name)))) (def: invoke::special Handler @@ -1195,7 +1195,7 @@ (analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (////.throw bundle.invalid-syntax extension-name)))) + (////.throw ///.invalid-syntax extension-name)))) (def: invoke::interface Handler @@ -1216,7 +1216,7 @@ (decorate-inputs argsT argsA))))) _ - (////.throw bundle.invalid-syntax extension-name)))) + (////.throw ///.invalid-syntax extension-name)))) (def: invoke::constructor Handler @@ -1231,7 +1231,7 @@ (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA))))) _ - (////.throw bundle.invalid-syntax extension-name)))) + (////.throw ///.invalid-syntax extension-name)))) (def: bundle::member Bundle diff --git a/stdlib/source/lux/compiler/default/phase/extension/bundle.lux b/stdlib/source/lux/compiler/default/phase/extension/bundle.lux index 4fe68b23c..582526694 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/bundle.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/bundle.lux @@ -1,8 +1,7 @@ (.module: [lux #* [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] + [monad (#+ do)]] [data ["." text format] @@ -11,15 +10,6 @@ ["." dictionary (#+ Dictionary)]]]] [// (#+ Handler Bundle)]) -(exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) - (ex.report ["Extension" (%t name)] - ["Expected arity" (|> arity .int %i)] - ["Actual arity" (|> args .int %i)])) - -(exception: #export (invalid-syntax {name Text}) - (ex.report ["Extension" name])) - -## [Utils] (def: #export empty Bundle (dictionary.new text.Hash<Text>)) diff --git a/stdlib/source/lux/compiler/default/phase/extension/statement.lux b/stdlib/source/lux/compiler/default/phase/extension/statement.lux index afc7c843c..6d2fbaa4e 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/statement.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/statement.lux @@ -12,21 +12,21 @@ ["." macro] [type (#+ :share) ["." check]]] - ["." /// - ["." analysis - ["." module] - ["." type]] - ["." synthesis] - ["." translation] - ["." statement (#+ Operation Handler Bundle)] - ["." extension - ["." bundle]]]) + ["." // + ["." bundle] + ["/." // + ["." analysis + ["." module] + ["." type]] + ["." synthesis] + ["." translation] + ["." statement (#+ Operation Handler Bundle)]]]) (def: (evaluate! type codeC) (All [anchor expression statement] (-> Type Code (Operation anchor expression statement [Type expression Any]))) (do ///.Monad<Operation> - [state (extension.lift ///.get-state) + [state (//.lift ///.get-state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) translate (get@ [#statement.translation #statement.phase] state)] @@ -52,7 +52,7 @@ (-> Name (Maybe Type) Code (Operation anchor expression statement [Type expression Text Any]))) (do ///.Monad<Operation> - [state (extension.lift ///.get-state) + [state (//.lift ///.get-state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) translate (get@ [#statement.translation #statement.phase] state)] @@ -90,7 +90,7 @@ [[_ annotationsT annotationsV] (evaluate! Code annotationsC) #let [annotationsV (:coerce Code annotationsV)] current-module (statement.lift-analysis - (extension.lift + (//.lift macro.current-module-name)) #let [full-name [current-module def-name]] [value//type valueT valueN valueV] (define! full-name @@ -114,12 +114,12 @@ (translation.learn full-name valueN))) _ - (///.throw bundle.invalid-syntax [extension-name])))) + (///.throw //.invalid-syntax [extension-name])))) (def: (alias! alias def-name) (-> Text Name (analysis.Operation Any)) (do ///.Monad<Operation> - [definition (extension.lift (macro.find-def def-name))] + [definition (//.lift (macro.find-def def-name))] (module.define alias definition))) (def: def::module @@ -134,20 +134,20 @@ (wrap [])) _ - (///.throw bundle.invalid-syntax [extension-name])))) + (///.throw //.invalid-syntax [extension-name])))) (def: def::alias Handler (function (_ extension-name phase inputsC+) (case inputsC+ (^ (list [_ (#.Identifier ["" alias])] [_ (#.Identifier def-name)])) - (extension.lift + (//.lift (///.sub [(get@ [#statement.analysis #statement.state]) (set@ [#statement.analysis #statement.state])] (alias! alias def-name))) _ - (///.throw bundle.invalid-syntax [extension-name])))) + (///.throw //.invalid-syntax [extension-name])))) (do-template [<mame> <type> <scope>] [(def: <mame> @@ -164,7 +164,7 @@ (:assume [])})) valueC)] (<| <scope> - (extension.install name) + (//.install name) (:share [anchor expression statement] {(Handler anchor expression statement) handler} @@ -172,7 +172,7 @@ (:assume handlerV)}))) _ - (///.throw bundle.invalid-syntax [extension-name]))))] + (///.throw //.invalid-syntax [extension-name]))))] [def::analysis analysis.Handler statement.lift-analysis] [def::synthesis synthesis.Handler statement.lift-synthesis] diff --git a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux index 65184a7ea..0854fcaa9 100644 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux @@ -20,7 +20,7 @@ ["." runtime (#+ Operation Phase Handler Bundle)] ["//." /// ["." synthesis (#+ Synthesis)] - [extension + ["." extension ["." bundle]] [/// [host @@ -38,24 +38,24 @@ ## [Utils] (syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!translate g!inputs] + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] (do @ [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) Handler) - (function ((~ g!_) (~ g!name) (~ g!translate) (~ g!inputs)) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) (case (~ g!inputs) (^ (list (~+ g!input+))) (do /////.Monad<Operation> [(~+ (|> g!input+ (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) + (list g!input (` ((~ g!phase) (~ g!input)))))) list.concat))] ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) (~' _) - (/////.throw bundle.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) (arity: nullary 0) (arity: unary 1) @@ -65,9 +65,9 @@ (def: #export (variadic extension) (-> Variadic Handler) (function (_ extension-name) - (function (_ translate inputsS) + (function (_ phase inputsS) (do /////.Monad<Operation> - [inputsI (monad.map @ translate inputsS)] + [inputsI (monad.map @ phase inputsS)] (wrap (extension inputsI)))))) ## [Bundle] |