diff options
Diffstat (limited to 'stdlib')
23 files changed, 1386 insertions, 1347 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index e76d59d1a..e375c7ed5 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -4029,11 +4029,11 @@ #None "???") ..new-line - "Known modules: " (|> modules - (list@map (function (_ [name module]) - (text$ name))) - tuple$ - code@encode)))) + "Known modules: " (|> modules + (list@map (function (_ [name module]) + (text$ name))) + tuple$ + code@encode)))) )) (def: (filter p xs) @@ -4243,8 +4243,8 @@ (|> args (list@map type@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")")) - (#Named [prefix name] _) - ($_ text@compose prefix "." name) + (#Named name _) + (name@encode name) )) (macro: #export (^open tokens) @@ -5706,36 +5706,54 @@ (function (_ compiler) (#Right [compiler (get@ [#info #target] compiler)]))) -(def: (pick-for-target target options) - (-> Text (List [Code Code]) (Maybe Code)) +(def: (target-pick target options default) + (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code))) (case options #Nil - #None + (case default + #.None + (fail ($_ text@compose "No code for target platform: " target)) - (#Cons [key value] options') - (case key - (^multi [_ (#Text platform)] - (text@= target platform)) - (#Some value) + (#.Some default) + (return (list default))) - _ - (pick-for-target target options')) + (#Cons [key pick] options') + (with-expansions [<try-again> (target-pick target options' default)] + (case key + [_ (#Text platform)] + (if (text@= target platform) + (return (list pick)) + <try-again>) + + [_ (#Identifier identifier)] + (do meta-monad + [identifier (..resolve-global-identifier identifier) + type+value (..find-def-value identifier) + #let [[type value] type+value]] + (case (..flatten-alias type) + (#Named ["lux" "Text"] (#Primitive "#Text" #Nil)) + (if (text@= target (:coerce ..Text value)) + (wrap (list pick)) + <try-again>) + + _ + (fail ($_ text@compose + "Invalid target platform (must be a value of type Text): " (name@encode identifier) + " : " (..code@encode (..type-to-code type)))))) + + _ + <try-again>)) )) (macro: #export (for tokens) (do meta-monad - [target target] + [target ..target] (case tokens (^ (list [_ (#Record options)])) - (case (pick-for-target target options) - (#Some pick) - (wrap (list pick)) - - #None - (fail ($_ text@compose "No code for target platform: " target))) + (target-pick target options #.None) (^ (list [_ (#Record options)] default)) - (wrap (list (..default default (pick-for-target target options)))) + (target-pick target options (#.Some default)) _ (fail (..wrong-syntax-error (name-of ..for)))))) diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index d15ccfc28..6abe4e756 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -13,73 +13,73 @@ [type abstract]]) -(`` (for {(~~ (static @.old)) - (host.import: #long (java/util/concurrent/atomic/AtomicReference a) - (new [a]) - (get [] a) - (compareAndSet [a a] boolean)) - - (~~ (static @.jvm)) - (host.import: #long (java/util/concurrent/atomic/AtomicReference a) - (new [a]) - (get [] a) - (compareAndSet [a a] boolean))} - (as-is))) - -(`` (abstract: #export (Atom a) - {#.doc "Atomic references that are safe to mutate concurrently."} - - (for {(~~ (static @.old)) - (java/util/concurrent/atomic/AtomicReference a) - - (~~ (static @.jvm)) - (java/util/concurrent/atomic/AtomicReference a) - - (~~ (static @.js)) - (array.Array a) - }) - - (def: #export (atom value) - (All [a] (-> a (Atom a))) - (:abstraction (for {(~~ (static @.old)) - (java/util/concurrent/atomic/AtomicReference::new value) - - (~~ (static @.jvm)) - (java/util/concurrent/atomic/AtomicReference::new value) - - (~~ (static @.js)) - ("js array write" 0 value ("js array new" 1)) - }))) - - (def: #export (read atom) - (All [a] (-> (Atom a) (IO a))) - (io (for {(~~ (static @.old)) - (java/util/concurrent/atomic/AtomicReference::get (:representation atom)) - - (~~ (static @.jvm)) - (java/util/concurrent/atomic/AtomicReference::get (:representation atom)) - - (~~ (static @.js)) - ("js array read" 0 (:representation atom)) - }))) - - (def: #export (compare-and-swap current new atom) - {#.doc (doc "Only mutates an atom if you can present its current value." - "That guarantees that atom was not updated since you last read from it.")} - (All [a] (-> a a (Atom a) (IO Bit))) - (io (for {(~~ (static @.old)) - (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)) - - (~~ (static @.jvm)) - (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)) - - (~~ (static @.js)) - (let [old ("js array read" 0 (:representation atom))] - (if (is? old current) - (exec ("js array write" 0 new (:representation atom)) - true) - false))}))) - )) +(for {@.old + (host.import: #long (java/util/concurrent/atomic/AtomicReference a) + (new [a]) + (get [] a) + (compareAndSet [a a] boolean)) + + @.jvm + (host.import: #long (java/util/concurrent/atomic/AtomicReference a) + (new [a]) + (get [] a) + (compareAndSet [a a] boolean))} + (as-is)) + +(abstract: #export (Atom a) + {#.doc "Atomic references that are safe to mutate concurrently."} + + (for {@.old + (java/util/concurrent/atomic/AtomicReference a) + + @.jvm + (java/util/concurrent/atomic/AtomicReference a) + + @.js + (array.Array a) + }) + + (def: #export (atom value) + (All [a] (-> a (Atom a))) + (:abstraction (for {@.old + (java/util/concurrent/atomic/AtomicReference::new value) + + @.jvm + (java/util/concurrent/atomic/AtomicReference::new value) + + @.js + ("js array write" 0 value ("js array new" 1)) + }))) + + (def: #export (read atom) + (All [a] (-> (Atom a) (IO a))) + (io (for {@.old + (java/util/concurrent/atomic/AtomicReference::get (:representation atom)) + + @.jvm + (java/util/concurrent/atomic/AtomicReference::get (:representation atom)) + + @.js + ("js array read" 0 (:representation atom)) + }))) + + (def: #export (compare-and-swap current new atom) + {#.doc (doc "Only mutates an atom if you can present its current value." + "That guarantees that atom was not updated since you last read from it.")} + (All [a] (-> a a (Atom a) (IO Bit))) + (io (for {@.old + (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)) + + @.jvm + (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)) + + @.js + (let [old ("js array read" 0 (:representation atom))] + (if (is? old current) + (exec ("js array write" 0 new (:representation atom)) + true) + false))}))) + ) (def: #export (update f atom) {#.doc (doc "Updates an atom by applying a function to its current value." diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index 2060233e3..4d6cc8cb3 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -15,143 +15,143 @@ [// ["." atom (#+ Atom)]]) -(`` (for {(~~ (static @.old)) - (as-is (host.import: #long java/lang/Object) +(for {@.old + (as-is (host.import: #long java/lang/Object) - (host.import: #long java/lang/Runtime - (#static getRuntime [] java/lang/Runtime) - (availableProcessors [] int)) + (host.import: #long java/lang/Runtime + (#static getRuntime [] java/lang/Runtime) + (availableProcessors [] int)) - (host.import: #long java/lang/Runnable) + (host.import: #long java/lang/Runnable) - (host.import: #long java/util/concurrent/TimeUnit - (#enum MILLISECONDS)) - - (host.import: #long java/util/concurrent/Executor - (execute [java/lang/Runnable] #io void)) + (host.import: #long java/util/concurrent/TimeUnit + (#enum MILLISECONDS)) + + (host.import: #long java/util/concurrent/Executor + (execute [java/lang/Runnable] #io void)) - (host.import: #long (java/util/concurrent/ScheduledFuture a)) + (host.import: #long (java/util/concurrent/ScheduledFuture a)) - (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor - (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) + (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) - (~~ (static @.jvm)) - (as-is (host.import: #long java/lang/Object) + @.jvm + (as-is (host.import: #long java/lang/Object) - (host.import: #long java/lang/Runtime - (#static getRuntime [] java/lang/Runtime) - (availableProcessors [] int)) + (host.import: #long java/lang/Runtime + (#static getRuntime [] java/lang/Runtime) + (availableProcessors [] int)) - (host.import: #long java/lang/Runnable) + (host.import: #long java/lang/Runnable) - (host.import: #long java/util/concurrent/TimeUnit - (#enum MILLISECONDS)) - - (host.import: #long java/util/concurrent/Executor - (execute [java/lang/Runnable] #io void)) + (host.import: #long java/util/concurrent/TimeUnit + (#enum MILLISECONDS)) + + (host.import: #long java/util/concurrent/Executor + (execute [java/lang/Runnable] #io void)) - (host.import: #long (java/util/concurrent/ScheduledFuture a)) + (host.import: #long (java/util/concurrent/ScheduledFuture a)) - (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor - (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))))} - - ## Default - (type: Process - {#creation Nat - #delay Nat - #action (IO Any)}) - )) + (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))))} + + ## Default + (type: Process + {#creation Nat + #delay Nat + #action (IO Any)}) + ) (def: #export parallelism Nat - (`` (for {(~~ (static @.old)) - (|> (java/lang/Runtime::getRuntime) - (java/lang/Runtime::availableProcessors) - .nat) - - (~~ (static @.jvm)) - (|> (java/lang/Runtime::getRuntime) - (java/lang/Runtime::availableProcessors) - .nat)} - - ## Default - 1))) + (for {@.old + (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) + .nat) + + @.jvm + (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) + .nat)} + + ## Default + 1)) (def: runner - (`` (for {(~~ (static @.old)) - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism)) + (for {@.old + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism)) - (~~ (static @.jvm)) - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))} - - ## Default - (: (Atom (List Process)) - (atom.atom (list)))))) + @.jvm + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))} + + ## Default + (: (Atom (List Process)) + (atom.atom (list))))) (def: #export (schedule milli-seconds action) (-> Nat (IO Any) (IO Any)) - (`` (for {(~~ (static @.old)) - (let [runnable (host.object [] [java/lang/Runnable] - [] - (java/lang/Runnable [] (run self) void - (io.run action)))] - (case milli-seconds - 0 (java/util/concurrent/Executor::execute runnable runner) - _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS - runner))) - - (~~ (static @.jvm)) - (let [runnable (host.object [] [java/lang/Runnable] - [] - (java/lang/Runnable [] (run self) void - (io.run action)))] - (case milli-seconds - 0 (java/util/concurrent/Executor::execute runnable runner) - _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS - runner)))} - - ## Default - (do io.monad - [_ (atom.update (|>> (#.Cons {#creation (.nat ("lux io current-time")) - #delay milli-seconds - #action action})) - runner)] - (wrap []))))) - -(`` (for {(~~ (static @.old)) - (as-is) - - (~~ (static @.jvm)) - (as-is)} - - ## Default - (as-is (exception: #export cannot-continue-running-processes) - - (def: #export run! - (IO Any) - (loop [_ []] - (do {@ io.monad} - [processes (atom.read runner)] - (case processes - ## And... we're done! - #.Nil - (wrap []) - - _ + (for {@.old + (let [runnable (host.object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run self) void + (io.run action)))] + (case milli-seconds + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner))) + + @.jvm + (let [runnable (host.object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run self) void + (io.run action)))] + (case milli-seconds + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner)))} + + ## Default + (do io.monad + [_ (atom.update (|>> (#.Cons {#creation (.nat ("lux io current-time")) + #delay milli-seconds + #action action})) + runner)] + (wrap [])))) + +(for {@.old + (as-is) + + @.jvm + (as-is)} + + ## Default + (as-is (exception: #export cannot-continue-running-processes) + + (def: #export run! + (IO Any) + (loop [_ []] + (do {@ io.monad} + [processes (atom.read runner)] + (case processes + ## And... we're done! + #.Nil + (wrap []) + + _ + (do @ + [#let [now (.nat ("lux io current-time")) + [ready pending] (list.partition (function (_ process) + (|> (get@ #creation process) + (n.+ (get@ #delay process)) + (n.<= now))) + processes)] + swapped? (atom.compare-and-swap processes pending runner)] + (if swapped? (do @ - [#let [now (.nat ("lux io current-time")) - [ready pending] (list.partition (function (_ process) - (|> (get@ #creation process) - (n.+ (get@ #delay process)) - (n.<= now))) - processes)] - swapped? (atom.compare-and-swap processes pending runner)] - (if swapped? - (do @ - [_ (monad.map @ (get@ #action) ready)] - (wrap [])) - (error! (ex.construct cannot-continue-running-processes [])))) - )))) - ))) + [_ (monad.map @ (get@ #action) ready)] + (wrap [])) + (error! (ex.construct cannot-continue-running-processes [])))) + )))) + )) diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux index 01c75a955..0b60d783a 100644 --- a/stdlib/source/lux/control/parser/cli.lux +++ b/stdlib/source/lux/control/parser/cli.lux @@ -160,13 +160,13 @@ (~ g!_) ..end] ((~' wrap) ((~! do) (~! io.monad) [(~ g!output) (~ body) - (~+ (`` (for {(~~ (static @.old)) - (list) - - (~~ (static @.jvm)) - (list)} - (list g!_ - (` process.run!)))))] + (~+ (for {@.old + (list) + + @.jvm + (list)} + (list g!_ + (` process.run!))))] ((~' wrap) (~ g!output)))))) (~ g!args)) (#try.Success [(~ g!_) (~ g!output)]) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index 7dfa4c490..31845e9c4 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -31,19 +31,19 @@ (def: #export (read box) (All [! a] (-> (Box ! a) (Thread ! a))) (function (_ !) - (`` (for {(~~ (static @.old)) - ("jvm aaload" (:representation box) 0) - - (~~ (static @.jvm)) - ("jvm array read object" - (|> 0 - (:coerce (primitive "java.lang.Long")) - "jvm object cast" - "jvm conversion long-to-int") - (:representation box)) - - (~~ (static @.js)) - ("js array read" 0 (:representation box))})))) + (for {@.old + ("jvm aaload" (:representation box) 0) + + @.jvm + ("jvm array read object" + (|> 0 + (:coerce (primitive "java.lang.Long")) + "jvm object cast" + "jvm conversion long-to-int") + (:representation box)) + + @.js + ("js array read" 0 (:representation box))}))) (def: #export (write value box) (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) diff --git a/stdlib/source/lux/control/writer.lux b/stdlib/source/lux/control/writer.lux index 1b82bf0c7..e92748aa5 100644 --- a/stdlib/source/lux/control/writer.lux +++ b/stdlib/source/lux/control/writer.lux @@ -60,11 +60,11 @@ (def: (join MlMla) (do monad - [[l1 Mla] (`` (for {(~~ (static @.old)) - (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2))))) - MlMla)} - ## On new compiler - MlMla)) + [[l1 Mla] (for {@.old + (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2))))) + MlMla)} + ## On new compiler + MlMla) [l2 a] Mla] (wrap [(:: monoid compose l1 l2) a])))) diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux index 3853e6aa5..4d3eb962a 100644 --- a/stdlib/source/lux/data/binary.lux +++ b/stdlib/source/lux/data/binary.lux @@ -55,64 +55,64 @@ (def: byte (-> (I64 Any) (primitive "java.lang.Byte")) - (`` (for {(~~ (static @.old)) - (|>> .int host.long-to-byte) - - (~~ (static @.jvm)) - (|>> .int (:coerce (primitive "java.lang.Long")) host.long-to-byte)}))))] - (`` (for {(~~ (static @.old)) - (as-is <for-jvm>) - - (~~ (static @.jvm)) - (as-is <for-jvm>) - - (~~ (static @.js)) - (as-is (host.import: ArrayBuffer - (new [host.Number])) - - (host.import: Uint8Array - (new [ArrayBuffer]) - (length host.Number)) - - (type: #export Binary Uint8Array))}))) + (for {@.old + (|>> .int host.long-to-byte) + + @.jvm + (|>> .int (:coerce (primitive "java.lang.Long")) host.long-to-byte)})))] + (for {@.old + (as-is <for-jvm>) + + @.jvm + (as-is <for-jvm>) + + @.js + (as-is (host.import: ArrayBuffer + (new [host.Number])) + + (host.import: Uint8Array + (new [ArrayBuffer]) + (length host.Number)) + + (type: #export Binary Uint8Array))})) (template: (!size binary) - (`` (for {(~~ (static @.old)) - (host.array-length binary) + (for {@.old + (host.array-length binary) - (~~ (static @.jvm)) - (host.array-length binary) + @.jvm + (host.array-length binary) - (~~ (static @.js)) - (.frac-to-nat (Uint8Array::length binary))}))) + @.js + (.frac-to-nat (Uint8Array::length binary))})) (template: (!read idx binary) - (`` (for {(~~ (static @.old)) - (..i64 (host.array-read idx binary)) + (for {@.old + (..i64 (host.array-read idx binary)) - (~~ (static @.jvm)) - (..i64 (host.array-read idx binary)) + @.jvm + (..i64 (host.array-read idx binary)) - (~~ (static @.js)) - (|> binary - (: ..Binary) - (:coerce (array.Array .Frac)) - ("js array read" idx) - .frac-to-nat)}))) + @.js + (|> binary + (: ..Binary) + (:coerce (array.Array .Frac)) + ("js array read" idx) + .frac-to-nat)})) (template: (!write idx value binary) - (`` (for {(~~ (static @.old)) - (host.array-write idx (..byte value) binary) + (for {@.old + (host.array-write idx (..byte value) binary) - (~~ (static @.jvm)) - (host.array-write idx (..byte value) binary) + @.jvm + (host.array-write idx (..byte value) binary) - (~~ (static @.js)) - (|> binary - (: ..Binary) - (:coerce (array.Array .Frac)) - ("js array write" idx (.nat-to-frac value)) - (:coerce ..Binary))}))) + @.js + (|> binary + (: ..Binary) + (:coerce (array.Array .Frac)) + ("js array write" idx (.nat-to-frac value)) + (:coerce ..Binary))})) (def: #export size (-> Binary Nat) @@ -120,14 +120,14 @@ (def: #export create (-> Nat Binary) - (`` (for {(~~ (static @.old)) - (|>> (host.array byte)) + (for {@.old + (|>> (host.array byte)) - (~~ (static @.jvm)) - (|>> (host.array byte)) + @.jvm + (|>> (host.array byte)) - (~~ (static @.js)) - (|>> .nat-to-frac [] ArrayBuffer::new Uint8Array::new)}))) + @.js + (|>> .nat-to-frac [] ArrayBuffer::new Uint8Array::new)})) (def: #export (fold f init binary) (All [a] (-> (-> I64 a a) a Binary a)) @@ -223,57 +223,57 @@ (Equivalence Binary) (def: (= reference sample) - (`` (for {(~~ (static @.old)) - (java/util/Arrays::equals reference sample) - - (~~ (static @.jvm)) - (java/util/Arrays::equals reference sample)} - (let [limit (!size reference)] - (and (n.= limit - (!size sample)) - (loop [idx 0] - (if (n.< limit idx) - (and (n.= (!read idx reference) - (!read idx sample)) - (recur (inc idx))) - true)))))))) - -(`` (for {(~~ (static @.old)) - (as-is) - - (~~ (static @.jvm)) - (as-is)} - - ## Default - (exception: #export (cannot-copy-bytes {source-input Nat} - {target-output Nat}) - (exception.report - ["Source input space" (%.nat source-input)] - ["Target output space" (%.nat target-output)])))) + (for {@.old + (java/util/Arrays::equals reference sample) + + @.jvm + (java/util/Arrays::equals reference sample)} + (let [limit (!size reference)] + (and (n.= limit + (!size sample)) + (loop [idx 0] + (if (n.< limit idx) + (and (n.= (!read idx reference) + (!read idx sample)) + (recur (inc idx))) + true))))))) + +(for {@.old + (as-is) + + @.jvm + (as-is)} + + ## Default + (exception: #export (cannot-copy-bytes {source-input Nat} + {target-output Nat}) + (exception.report + ["Source input space" (%.nat source-input)] + ["Target output space" (%.nat target-output)]))) (def: #export (copy bytes source-offset source target-offset target) (-> Nat Nat Binary Nat Binary (Try Binary)) (with-expansions [<for-jvm> (as-is (do try.monad [_ (java/lang/System::arraycopy source (.int source-offset) target (.int target-offset) (.int bytes))] (wrap target)))] - (`` (for {(~~ (static @.old)) - <for-jvm> - - (~~ (static @.jvm)) - <for-jvm>} - - ## Default - (let [source-input (n.- source-offset (!size source)) - target-output (n.- target-offset (!size target))] - (if (n.<= target-output source-input) - (loop [idx 0] - (if (n.< source-input idx) - (exec (!write (n.+ target-offset idx) - (!read (n.+ source-offset idx) source) - target) - (recur (inc idx))) - (#try.Success target))) - (exception.throw ..cannot-copy-bytes [source-input target-output]))))))) + (for {@.old + <for-jvm> + + @.jvm + <for-jvm>} + + ## Default + (let [source-input (n.- source-offset (!size source)) + target-output (n.- target-offset (!size target))] + (if (n.<= target-output source-input) + (loop [idx 0] + (if (n.< source-input idx) + (exec (!write (n.+ target-offset idx) + (!read (n.+ source-offset idx) source) + target) + (recur (inc idx))) + (#try.Success target))) + (exception.throw ..cannot-copy-bytes [source-input target-output])))))) (def: #export (slice from to binary) (-> Nat Nat Binary (Try Binary)) @@ -282,15 +282,15 @@ (if (and (n.< size from) (n.< size to)) (with-expansions [<for-jvm> (as-is (#try.Success (java/util/Arrays::copyOfRange binary (.int from) (.int (inc to)))))] - (`` (for {(~~ (static @.old)) - <for-jvm> - - (~~ (static @.jvm)) - <for-jvm>} - - ## Default - (let [how-many (n.- from to)] - (..copy how-many from binary 0 (..create how-many)))))) + (for {@.old + <for-jvm> + + @.jvm + <for-jvm>} + + ## Default + (let [how-many (n.- from to)] + (..copy how-many from binary 0 (..create how-many))))) (exception.throw ..slice-out-of-bounds [size from to])) (exception.throw ..inverted-slice [size from to])))) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index b71e2fb2d..6d2e7c16d 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -24,98 +24,98 @@ (with-expansions [<index-type> (primitive "java.lang.Long") <elem-type> (primitive "java.lang.Object") <array-type> (type (Array <elem-type>))] - (`` (for {(~~ (static @.jvm)) - (template: (!int value) - (|> value - (:coerce <index-type>) - "jvm object cast" - "jvm conversion long-to-int"))} - (as-is))) + (for {@.jvm + (template: (!int value) + (|> value + (:coerce <index-type>) + "jvm object cast" + "jvm conversion long-to-int"))} + (as-is)) (def: #export (new size) (All [a] (-> Nat (Array a))) - (`` (for {(~~ (static @.old)) - (:assume ("jvm anewarray" "(java.lang.Object )" size)) + (for {@.old + (:assume ("jvm anewarray" "(java.lang.Object )" size)) - (~~ (static @.jvm)) - (|> size - !int - "jvm array new object" - (: <array-type>) - :assume) + @.jvm + (|> size + !int + "jvm array new object" + (: <array-type>) + :assume) - (~~ (static @.js)) - ("js array new" size)}))) + @.js + ("js array new" size)})) (def: #export (size array) (All [a] (-> (Array a) Nat)) - (`` (for {(~~ (static @.old)) - ("jvm arraylength" array) + (for {@.old + ("jvm arraylength" array) - (~~ (static @.jvm)) - (|> array - (:coerce <array-type>) - "jvm array length object" - "jvm conversion int-to-long" - "jvm object cast" - (: <index-type>) - (:coerce Nat)) + @.jvm + (|> array + (:coerce <array-type>) + "jvm array length object" + "jvm conversion int-to-long" + "jvm object cast" + (: <index-type>) + (:coerce Nat)) - (~~ (static @.js)) - ("js array length" array)}))) + @.js + ("js array length" array)})) (def: #export (read index array) (All [a] (-> Nat (Array a) (Maybe a))) (if (n.< (size array) index) - (`` (for {(~~ (static @.old)) - (let [value ("jvm aaload" array index)] - (if ("jvm object null?" value) - #.None - (#.Some value))) - - (~~ (static @.jvm)) - (let [value (|> array - (:coerce <array-type>) - ("jvm array read object" (!int index)))] - (if ("jvm object null?" value) - #.None - (#.Some (:assume value)))) - - (~~ (static @.js)) - (let [output ("js array read" index array)] - (if ("js object undefined?" output) - #.None - (#.Some output)))})) + (for {@.old + (let [value ("jvm aaload" array index)] + (if ("jvm object null?" value) + #.None + (#.Some value))) + + @.jvm + (let [value (|> array + (:coerce <array-type>) + ("jvm array read object" (!int index)))] + (if ("jvm object null?" value) + #.None + (#.Some (:assume value)))) + + @.js + (let [output ("js array read" index array)] + (if ("js object undefined?" output) + #.None + (#.Some output)))}) #.None)) (def: #export (write index value array) (All [a] (-> Nat a (Array a) (Array a))) - (`` (for {(~~ (static @.old)) - ("jvm aastore" array index value) + (for {@.old + ("jvm aastore" array index value) - (~~ (static @.jvm)) - (|> array - (:coerce <array-type>) - ("jvm array write object" (!int index) (:coerce <elem-type> value)) - :assume) + @.jvm + (|> array + (:coerce <array-type>) + ("jvm array write object" (!int index) (:coerce <elem-type> value)) + :assume) - (~~ (static @.js)) - ("js array write" index value array)}))) + @.js + ("js array write" index value array)})) (def: #export (delete index array) (All [a] (-> Nat (Array a) (Array a))) (if (n.< (size array) index) - (`` (for {(~~ (static @.old)) - (write index (:assume ("jvm object null")) array) + (for {@.old + (write index (:assume ("jvm object null")) array) - (~~ (static @.jvm)) - (write index (:assume (: <elem-type> ("jvm object null"))) array) + @.jvm + (write index (:assume (: <elem-type> ("jvm object null"))) array) - (~~ (static @.js)) - ("js array delete" index array)})) + @.js + ("js array delete" index array)}) array)) ) diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux index a705908d1..9debb89eb 100644 --- a/stdlib/source/lux/data/collection/list.lux +++ b/stdlib/source/lux/data/collection/list.lux @@ -575,10 +575,10 @@ (do {@ monad} [lMla MlMla ## TODO: Remove this version ASAP and use one below. - lla (`` (for {(~~ (static @.old)) - (: (($ 0) (List (List ($ 1)))) - (monad.seq @ lMla))} - (monad.seq @ lMla)))] + lla (for {@.old + (: (($ 0) (List (List ($ 1)))) + (monad.seq @ lMla))} + (monad.seq @ lMla))] (wrap (concat lla))))) (def: #export (lift monad) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux index 2b7b555be..6df0325cd 100644 --- a/stdlib/source/lux/data/collection/row.lux +++ b/stdlib/source/lux/data/collection/row.lux @@ -211,10 +211,10 @@ ## If so, a brand-new root must be established, that is ## 1-level taller. (|> row - (set@ #root (|> (`` (for {(~~ (static @.old)) - (: (Hierarchy ($ 0)) - (new-hierarchy []))} - (new-hierarchy []))) + (set@ #root (|> (for {@.old + (: (Hierarchy ($ 0)) + (new-hierarchy []))} + (new-hierarchy [])) (array.write 0 (#Hierarchy (get@ #root row))) (array.write 1 (new-path (get@ #level row) (get@ #tail row))))) (update@ #level level-up)) @@ -278,10 +278,10 @@ (let [row-size (get@ #size row)] (if (within-bounds? row idx) (#try.Success (if (n.>= (tail-off row-size) idx) - (update@ #tail (`` (for {(~~ (static @.old)) - (: (-> (Base ($ 0)) (Base ($ 0))) - (|>> array.clone (array.write (branch-idx idx) val)))} - (|>> array.clone (array.write (branch-idx idx) val)))) + (update@ #tail (for {@.old + (: (-> (Base ($ 0)) (Base ($ 0))) + (|>> array.clone (array.write (branch-idx idx) val)))} + (|>> array.clone (array.write (branch-idx idx) val))) row) (update@ #root (put' (get@ #level row) idx val) row))) diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux index 029c27390..47e125e4a 100644 --- a/stdlib/source/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/lux/data/collection/tree/zipper.lux @@ -94,17 +94,17 @@ zipper (#.Some parent) - (`` (for {(~~ (static @.old)) - (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) - (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))))) - parent)} - (set@ [#node #//.children] - (list@compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))) - parent))))) + (for {@.old + (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) + (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))))) + parent)} + (set@ [#node #//.children] + (list@compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + parent)))) (def: #export (start zipper) (All [a] (-> (Zipper a) (Zipper a))) @@ -197,10 +197,10 @@ (All [a] (-> a (Zipper a) (Zipper a))) (update@ [#node #//.children] (function (_ children) - (list& (`` (for {(~~ (static @.old)) - (: (Tree ($ 0)) - (//.tree [value {}]))} - (//.tree [value {}]))) + (list& (for {@.old + (: (Tree ($ 0)) + (//.tree [value {}]))} + (//.tree [value {}])) children)) zipper)) @@ -209,10 +209,10 @@ (update@ [#node #//.children] (function (_ children) (list@compose children - (list (`` (for {(~~ (static @.old)) - (: (Tree ($ 0)) - (//.tree [value {}]))} - (//.tree [value {}])))))) + (list (for {@.old + (: (Tree ($ 0)) + (//.tree [value {}]))} + (//.tree [value {}]))))) zipper)) (def: #export (remove zipper) @@ -242,10 +242,10 @@ _ (#.Some (|> zipper (update@ <side> (function (_ side) - (#.Cons (`` (for {(~~ (static @.old)) - (: (Tree ($ 0)) - (//.tree [value {}]))} - (//.tree [value {}]))) + (#.Cons (for {@.old + (: (Tree ($ 0)) + (//.tree [value {}]))} + (//.tree [value {}])) side)))))))] [insert-left #lefts] @@ -259,20 +259,20 @@ #rights (|> fa (get@ #rights) (list@map (//@map f))) #node (//@map f (get@ #node fa))})) -(`` (for {(~~ (static @.old)) - (as-is)} - (structure: #export comonad (CoMonad Zipper) - (def: &functor ..functor) - - (def: unwrap (get@ [#node #//.value])) - - (def: (split [parent lefts rights node]) - (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) - (function (tree-splitter tree) - {#//.value (zip tree) - #//.children (list@map tree-splitter - (get@ #//.children tree))}))] - {#parent (maybe@map split parent) - #lefts (list@map tree-splitter lefts) - #rights (list@map tree-splitter rights) - #node (tree-splitter node)}))))) +(for {@.old + (as-is)} + (structure: #export comonad (CoMonad Zipper) + (def: &functor ..functor) + + (def: unwrap (get@ [#node #//.value])) + + (def: (split [parent lefts rights node]) + (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) + (function (tree-splitter tree) + {#//.value (zip tree) + #//.children (list@map tree-splitter + (get@ #//.children tree))}))] + {#parent (maybe@map split parent) + #lefts (list@map tree-splitter lefts) + #rights (list@map tree-splitter rights) + #node (tree-splitter node)})))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index d257c88ee..069dd8590 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -188,32 +188,32 @@ (def: &equivalence ..equivalence) (def: (hash input) - (`` (for {(~~ (static @.old)) - (|> input - (: (primitive "java.lang.String")) - "jvm invokevirtual:java.lang.String:hashCode:" - "jvm convert int-to-long" - (:coerce Nat)) - - (~~ (static @.jvm)) - (|> input - (:coerce (primitive "java.lang.String")) - ("jvm member invoke virtual" [] "java.lang.String" "hashCode" []) - "jvm conversion int-to-long" - "jvm object cast" - (: (primitive "java.lang.Long")) - (:coerce Nat))} - ## Platform-independent default. - (let [length ("lux text size" input)] - (loop [idx 0 - hash 0] - (if (n.< length idx) - (recur (inc idx) - (|> hash - (i64.left-shift 5) - (n.- hash) - (n.+ ("lux text char" idx input)))) - hash))))))) + (for {@.old + (|> input + (: (primitive "java.lang.String")) + "jvm invokevirtual:java.lang.String:hashCode:" + "jvm convert int-to-long" + (:coerce Nat)) + + @.jvm + (|> input + (:coerce (primitive "java.lang.String")) + ("jvm member invoke virtual" [] "java.lang.String" "hashCode" []) + "jvm conversion int-to-long" + "jvm object cast" + (: (primitive "java.lang.Long")) + (:coerce Nat))} + ## Platform-independent default. + (let [length ("lux text size" input)] + (loop [idx 0 + hash 0] + (if (n.< length idx) + (recur (inc idx) + (|> hash + (i64.left-shift 5) + (n.- hash) + (n.+ ("lux text char" idx input)))) + hash)))))) (def: #export concat (-> (List Text) Text) diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index 9e94f25af..1ef044080 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -174,50 +174,50 @@ (with-expansions [<for-jvm> (as-is (host.import: #long java/lang/String (new [[byte] java/lang/String]) (getBytes [java/lang/String] [byte])))] - (`` (for {(~~ (static @.old)) - (as-is <for-jvm>) - - (~~ (static @.jvm)) - (as-is <for-jvm>) - - (~~ (static @.js)) - (as-is (host.import: Uint8Array) - - (host.import: TextEncoder - (new [host.String]) - (encode [host.String] Uint8Array)) - - (host.import: TextDecoder - (new [host.String]) - (decode [Uint8Array] host.String)))}))) + (for {@.old + (as-is <for-jvm>) + + @.jvm + (as-is <for-jvm>) + + @.js + (as-is (host.import: Uint8Array) + + (host.import: TextEncoder + (new [host.String]) + (encode [host.String] Uint8Array)) + + (host.import: TextDecoder + (new [host.String]) + (decode [Uint8Array] host.String)))})) (def: #export (to-utf8 value) (-> Text Binary) - (`` (for {(~~ (static @.old)) - (java/lang/String::getBytes (..name ..utf-8) - ## The coercion below may seem - ## gratuitous, but removing it - ## causes a grave compilation problem. - (:coerce java/lang/String value)) + (for {@.old + (java/lang/String::getBytes (..name ..utf-8) + ## The coercion below may seem + ## gratuitous, but removing it + ## causes a grave compilation problem. + (:coerce java/lang/String value)) - (~~ (static @.jvm)) - (java/lang/String::getBytes (..name ..utf-8) value) + @.jvm + (java/lang/String::getBytes (..name ..utf-8) value) - (~~ (static @.js)) - (|> (TextEncoder::new [(..name ..utf-8)]) - (TextEncoder::encode [value]))}))) + @.js + (|> (TextEncoder::new [(..name ..utf-8)]) + (TextEncoder::encode [value]))})) (def: #export (from-utf8 value) (-> Binary (Try Text)) - (`` (for {(~~ (static @.old)) - (#try.Success (java/lang/String::new value (..name ..utf-8))) + (for {@.old + (#try.Success (java/lang/String::new value (..name ..utf-8))) - (~~ (static @.jvm)) - (#try.Success (java/lang/String::new value (..name ..utf-8))) + @.jvm + (#try.Success (java/lang/String::new value (..name ..utf-8))) - (~~ (static @.js)) - (#try.Success (|> (TextDecoder::new [(..name ..utf-8)]) - (TextDecoder::decode [value])))}))) + @.js + (#try.Success (|> (TextDecoder::new [(..name ..utf-8)]) + (TextDecoder::decode [value])))})) (structure: #export UTF-8 (Codec Binary Text) diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux index bac74880f..f46c3334b 100644 --- a/stdlib/source/lux/debug.lux +++ b/stdlib/source/lux/debug.lux @@ -48,17 +48,17 @@ (intValue [] int) (longValue [] long) (doubleValue [] double)))] - (`` (for {(~~ (static @.old)) - (as-is <for-jvm>) + (for {@.old + (as-is <for-jvm>) - (~~ (static @.jvm)) - (as-is <for-jvm>) + @.jvm + (as-is <for-jvm>) - (~~ (static @.js)) - (as-is (import: JSON - (#static stringify [.Any] host.String)) - (import: Array - (#static isArray [.Any] host.Boolean)))}))) + @.js + (as-is (import: JSON + (#static stringify [.Any] host.String)) + (import: Array + (#static isArray [.Any] host.Boolean)))})) (def: Inspector (-> Any Text)) @@ -107,47 +107,47 @@ (inspect-tuple inspect value))) #.None) (java/lang/Object::toString object))))] - (`` (for {(~~ (static @.old)) - <for-jvm> - - (~~ (static @.jvm)) - <for-jvm> - - (~~ (static @.js)) - (~~ (case (host.type-of value) - (^template [<type-of> <then>] - <type-of> - (`` (|> value (~~ (template.splice <then>))))) - (["boolean" [(:coerce .Bit) %.bit]] - ["string" [(:coerce .Text) %t]] - ["number" [(:coerce .Frac) %f]] - ["undefined" [JSON::stringify]]) + (for {@.old + <for-jvm> + + @.jvm + <for-jvm> + + @.js + (case (host.type-of value) + (^template [<type-of> <then>] + <type-of> + (`` (|> value (~~ (template.splice <then>))))) + (["boolean" [(:coerce .Bit) %.bit]] + ["string" [(:coerce .Text) %t]] + ["number" [(:coerce .Frac) %f]] + ["undefined" [JSON::stringify]]) + + "object" + (let [variant-tag ("js object get" "_lux_tag" value) + variant-flag ("js object get" "_lux_flag" value) + variant-value ("js object get" "_lux_value" value)] + (cond (not (or ("js object undefined?" variant-tag) + ("js object undefined?" variant-flag) + ("js object undefined?" variant-value))) + (|> (format (JSON::stringify variant-tag) + " " (%.bit (not ("js object null?" variant-flag))) + " " (inspect variant-value)) + (text.enclose ["(" ")"])) + + (not (or ("js object undefined?" ("js object get" "_lux_low" value)) + ("js object undefined?" ("js object get" "_lux_high" value)))) + (|> value (:coerce .Int) %.int) + + (Array::isArray value) + (inspect-tuple inspect value) - "object" - (let [variant-tag ("js object get" "_lux_tag" value) - variant-flag ("js object get" "_lux_flag" value) - variant-value ("js object get" "_lux_value" value)] - (cond (not (or ("js object undefined?" variant-tag) - ("js object undefined?" variant-flag) - ("js object undefined?" variant-value))) - (|> (format (JSON::stringify variant-tag) - " " (%.bit (not ("js object null?" variant-flag))) - " " (inspect variant-value)) - (text.enclose ["(" ")"])) - - (not (or ("js object undefined?" ("js object get" "_lux_low" value)) - ("js object undefined?" ("js object get" "_lux_high" value)))) - (|> value (:coerce .Int) %.int) - - (Array::isArray value) - (inspect-tuple inspect value) - - ## else - (JSON::stringify value))) - - _ - (undefined))) - })))) + ## else + (JSON::stringify value))) + + _ + (undefined)) + }))) (exception: #export (cannot-represent-value {type Type}) (exception.report diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 6f3448f7d..ac6a442f8 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -16,84 +16,84 @@ [tau +6.28318530717958647692 "The ratio of a circle's circumference to its radius."] ) -(`` (for {(~~ (static @.old)) - (as-is (template [<name> <method>] - [(def: #export (<name> input) - (-> Frac Frac) - (<method> input))] - - [cos "jvm invokestatic:java.lang.Math:cos:double"] - [sin "jvm invokestatic:java.lang.Math:sin:double"] - [tan "jvm invokestatic:java.lang.Math:tan:double"] - - [acos "jvm invokestatic:java.lang.Math:acos:double"] - [asin "jvm invokestatic:java.lang.Math:asin:double"] - [atan "jvm invokestatic:java.lang.Math:atan:double"] - - [exp "jvm invokestatic:java.lang.Math:exp:double"] - [log "jvm invokestatic:java.lang.Math:log:double"] - - [ceil "jvm invokestatic:java.lang.Math:ceil:double"] - [floor "jvm invokestatic:java.lang.Math:floor:double"] - ) - (def: #export (pow param subject) - (-> Frac Frac Frac) - ("jvm invokestatic:java.lang.Math:pow:double,double" subject param))) - - (~~ (static @.jvm)) - (as-is (template: (!double value) (|> value (:coerce (primitive "java.lang.Double")) "jvm object cast")) - (template: (!frac value) (|> value "jvm object cast" (: (primitive "java.lang.Double")) (:coerce Frac))) - (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> !double - ["D"] - ("jvm member invoke static" [] "java.lang.Math" <method> []) - !frac))] - - [cos "cos"] - [sin "sin"] - [tan "tan"] - - [acos "acos"] - [asin "asin"] - [atan "atan"] - - [exp "exp"] - [log "log"] - - [ceil "ceil"] - [floor "floor"] - ) - (def: #export (pow param subject) - (-> Frac Frac Frac) - (|> ("jvm member invoke static" [] "java.lang.Math" "pow" [] - ["D" (!double subject)] ["D" (!double param)]) - !frac))) - - (~~ (static @.js)) - (as-is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("js apply" ("js constant" <method>)) (:coerce Frac)))] - - [cos "Math.cos"] - [sin "Math.sin"] - [tan "Math.tan"] - - [acos "Math.acos"] - [asin "Math.asin"] - [atan "Math.atan"] - - [exp "Math.exp"] - [log "Math.log"] - - [ceil "Math.ceil"] - [floor "Math.floor"] - ) - (def: #export (pow param subject) - (-> Frac Frac Frac) - (:coerce Frac ("js apply" ("js constant" "Math.pow") subject param))))})) +(for {@.old + (as-is (template [<name> <method>] + [(def: #export (<name> input) + (-> Frac Frac) + (<method> input))] + + [cos "jvm invokestatic:java.lang.Math:cos:double"] + [sin "jvm invokestatic:java.lang.Math:sin:double"] + [tan "jvm invokestatic:java.lang.Math:tan:double"] + + [acos "jvm invokestatic:java.lang.Math:acos:double"] + [asin "jvm invokestatic:java.lang.Math:asin:double"] + [atan "jvm invokestatic:java.lang.Math:atan:double"] + + [exp "jvm invokestatic:java.lang.Math:exp:double"] + [log "jvm invokestatic:java.lang.Math:log:double"] + + [ceil "jvm invokestatic:java.lang.Math:ceil:double"] + [floor "jvm invokestatic:java.lang.Math:floor:double"] + ) + (def: #export (pow param subject) + (-> Frac Frac Frac) + ("jvm invokestatic:java.lang.Math:pow:double,double" subject param))) + + @.jvm + (as-is (template: (!double value) (|> value (:coerce (primitive "java.lang.Double")) "jvm object cast")) + (template: (!frac value) (|> value "jvm object cast" (: (primitive "java.lang.Double")) (:coerce Frac))) + (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> !double + ["D"] + ("jvm member invoke static" [] "java.lang.Math" <method> []) + !frac))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [exp "exp"] + [log "log"] + + [ceil "ceil"] + [floor "floor"] + ) + (def: #export (pow param subject) + (-> Frac Frac Frac) + (|> ("jvm member invoke static" [] "java.lang.Math" "pow" [] + ["D" (!double subject)] ["D" (!double param)]) + !frac))) + + @.js + (as-is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("js apply" ("js constant" <method>)) (:coerce Frac)))] + + [cos "Math.cos"] + [sin "Math.sin"] + [tan "Math.tan"] + + [acos "Math.acos"] + [asin "Math.asin"] + [atan "Math.atan"] + + [exp "Math.exp"] + [log "Math.log"] + + [ceil "Math.ceil"] + [floor "Math.floor"] + ) + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:coerce Frac ("js apply" ("js constant" "Math.pow") subject param))))}) (def: #export (round input) (-> Frac Frac) diff --git a/stdlib/source/lux/target.lux b/stdlib/source/lux/target.lux index 06c4c7efe..c33e5b045 100644 --- a/stdlib/source/lux/target.lux +++ b/stdlib/source/lux/target.lux @@ -1,7 +1,8 @@ (.module: lux) -(type: #export Host Text) +(type: #export Host + Text) (template [<name> <value>] [(def: #export <name> Host <value>)] diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux index 3e225a7c2..2d90e618d 100644 --- a/stdlib/source/lux/target/jvm/constant.lux +++ b/stdlib/source/lux/target/jvm/constant.lux @@ -67,13 +67,13 @@ (Equivalence java/lang/Float) (def: (= parameter subject) - (`` (for {(~~ (static @.old)) - ("jvm feq" parameter subject) - - (~~ (static @.jvm)) - ("jvm float =" - ("jvm object cast" parameter) - ("jvm object cast" subject))})))) + (for {@.old + ("jvm feq" parameter subject) + + @.jvm + ("jvm float =" + ("jvm object cast" parameter) + ("jvm object cast" subject))}))) (import: #long java/lang/Double (#static doubleToRawLongBits [double] long)) diff --git a/stdlib/source/lux/target/jvm/loader.lux b/stdlib/source/lux/target/jvm/loader.lux index f7d736766..33a16f782 100644 --- a/stdlib/source/lux/target/jvm/loader.lux +++ b/stdlib/source/lux/target/jvm/loader.lux @@ -95,30 +95,30 @@ (def: #export (memory library) (-> Library java/lang/ClassLoader) - (`` (with-expansions [<cast> (for {(~~ (static @.old)) - (<|) - - (~~ (static @.jvm)) - "jvm object cast"})] - (<| <cast> - (object [] java/lang/ClassLoader [] - [] - (java/lang/ClassLoader (findClass self {class-name java/lang/String}) - (java/lang/Class [? < java/lang/Object]) - #throws [java/lang/ClassNotFoundException] - (let [class-name (:coerce Text class-name) - classes (|> library atom.read io.run)] - (case (dictionary.get class-name classes) - (#.Some bytecode) - (case (..define class-name bytecode (<| <cast> self)) - (#try.Success class) - (:assume class) - - (#try.Failure error) - (error! (exception.construct ..cannot-define [class-name error]))) - - #.None - (error! (exception.construct ..unknown [class-name (dictionary.keys classes)])))))))))) + (with-expansions [<cast> (for {@.old + (<|) + + @.jvm + "jvm object cast"})] + (<| <cast> + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass self {class-name java/lang/String}) + (java/lang/Class [? < java/lang/Object]) + #throws [java/lang/ClassNotFoundException] + (let [class-name (:coerce Text class-name) + classes (|> library atom.read io.run)] + (case (dictionary.get class-name classes) + (#.Some bytecode) + (case (..define class-name bytecode (<| <cast> self)) + (#try.Success class) + (:assume class) + + (#try.Failure error) + (error! (exception.construct ..cannot-define [class-name error]))) + + #.None + (error! (exception.construct ..unknown [class-name (dictionary.keys classes)]))))))))) (def: #export (store name bytecode library) (-> Text Binary Library (IO (Try Any))) diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index 89d36be8a..a308c50b4 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -106,12 +106,12 @@ (def: can-close (..can-close (|>> (ex.throw cannot-close) wrap))))))))))] - (`` (for {(~~ (static @.old)) - (as-is <form-jvm>) + (for {@.old + (as-is <form-jvm>) - (~~ (static @.jvm)) - (as-is <form-jvm>) - }))) + @.jvm + (as-is <form-jvm>) + })) (def: #export (write-line message console) (All [!] (-> Text (Console !) (! Any))) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 8ef16a276..f3fffe1c9 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -214,24 +214,24 @@ (import: #long java/lang/String) - (import: #long java/io/File - (new [java/lang/String]) - (~~ (template [<name>] - [(<name> [] #io #try boolean)] - - [createNewFile] [mkdir] - [exists] [delete] - [isFile] [isDirectory] - [canRead] [canWrite] [canExecute])) - - (getName [] java/lang/String) - (length [] #io #try long) - (listFiles [] #io #try #? [java/io/File]) - (getAbsolutePath [] #io #try java/lang/String) - (renameTo [java/io/File] #io #try boolean) - (lastModified [] #io #try long) - (setLastModified [long] #io #try boolean) - (#static separator java/lang/String)) + (`` (import: #long java/io/File + (new [java/lang/String]) + (~~ (template [<name>] + [(<name> [] #io #try boolean)] + + [createNewFile] [mkdir] + [exists] [delete] + [isFile] [isDirectory] + [canRead] [canWrite] [canExecute])) + + (getName [] java/lang/String) + (length [] #io #try long) + (listFiles [] #io #try #? [java/io/File]) + (getAbsolutePath [] #io #try java/lang/String) + (renameTo [java/io/File] #io #try boolean) + (lastModified [] #io #try long) + (setLastModified [long] #io #try boolean) + (#static separator java/lang/String))) (template: (!delete path exception) (do io.monad @@ -259,205 +259,205 @@ (import: #long java/io/FileInputStream (new [java/io/File] #io #try)) - (structure: (file path) - (-> Path (File IO)) - - (~~ (template [<name> <flag>] - [(def: <name> - (..can-modify - (function (<name> data) - (do (try.with io.monad) - [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>) - _ (java/io/OutputStream::write data stream) - _ (java/io/OutputStream::flush stream)] - (java/lang/AutoCloseable::close stream)))))] - - [over-write #0] - [append #1] - )) - - (def: content - (..can-query - (function (content _) - (do (try.with io.monad) - [#let [file (java/io/File::new path)] - size (java/io/File::length file) - #let [data (binary.create (.nat size))] - stream (java/io/FileInputStream::new file) - bytes-read (java/io/InputStream::read data stream) - _ (java/lang/AutoCloseable::close stream)] - (if (i.= size bytes-read) - (wrap data) - (io.io (exception.throw cannot-read-all-data path))))))) - - (def: name - (..can-see - (function (name _) - (|> path - java/io/File::new - java/io/File::getName)))) - - (def: path - (..can-see - (function (_ _) - path))) - - (def: size - (..can-query - (function (size _) - (|> path - java/io/File::new - java/io/File::length - (:: (try.with io.monad) map .nat))))) - - (def: last-modified - (..can-query - (function (last-modified _) - (|> path - java/io/File::new - (java/io/File::lastModified) - (:: (try.with io.monad) map (|>> duration.from-millis instant.absolute)))))) - - (def: can-execute? - (..can-query - (function (can-execute? _) - (|> path - java/io/File::new - java/io/File::canExecute)))) - - (def: move - (..can-open - (function (move destination) - (do io.monad - [outcome (java/io/File::renameTo (java/io/File::new destination) - (java/io/File::new path))] - (case outcome - (#try.Success #1) - (wrap (#try.Success (file destination))) - - _ - (io.io (exception.throw cannot-move [destination path]))))))) - - (def: modify - (..can-modify - (function (modify time-stamp) - (do io.monad - [outcome (java/io/File::setLastModified (|> time-stamp instant.relative duration.to-millis) - (java/io/File::new path))] - (case outcome - (#try.Success #1) - (wrap (#try.Success [])) - - _ - (io.io (exception.throw cannot-modify [time-stamp path]))))))) - - (def: delete - (..can-delete - (function (delete _) - (!delete path cannot-delete-file))))) - - (structure: (directory path) - (-> Path (Directory IO)) - - (~~ (template [<name> <method> <capability>] - [(def: <name> - (..can-query - (function (<name> _) - (do {@ (try.with io.monad)} - [?children (java/io/File::listFiles (java/io/File::new path))] - (case ?children - (#.Some children) - (|> children - array.to-list - (monad.filter @ (|>> <method>)) - (:: @ map (monad.map @ (|>> java/io/File::getAbsolutePath (:: @ map <capability>)))) - (:: @ join)) - - #.None - (io.io (exception.throw not-a-directory [path])))))))] - - [files java/io/File::isFile file] - [directories java/io/File::isDirectory directory] - )) - - (def: discard - (..can-delete - (function (discard _) - (!delete path cannot-discard-directory))))) - - (structure: #export system - (System IO) - - (~~ (template [<name> <method> <capability> <exception>] - [(def: <name> - (..can-open - (function (<name> path) - (do io.monad - [#let [file (java/io/File::new path)] - outcome (<method> file)] - (case outcome - (#try.Success #1) - (wrap (#try.Success (<capability> path))) - - _ - (wrap (exception.throw <exception> [path])))))))] - - [file java/io/File::isFile ..file cannot-find-file] - [create-file java/io/File::createNewFile ..file cannot-create-file] - [directory java/io/File::isDirectory ..directory cannot-find-directory] - [create-directory java/io/File::mkdir ..directory cannot-create-directory] - )) - - (def: separator (java/io/File::separator)) - ))] - (`` (for {(~~ (static @.old)) - (as-is <for-jvm>) - - (~~ (static @.jvm)) - (as-is <for-jvm>) - - (~~ (static @.js)) - (as-is (import: Buffer - (#static from [Binary] ..Buffer)) - - (import: FileDescriptor) - - (import: Stats - (size host.Number) - (mtimeMs host.Number) - (isFile [] #try host.Boolean) - (isDirectory [] #try host.Boolean)) - - (import: FsConstants - (F_OK host.Number) - (R_OK host.Number) - (W_OK host.Number) - (X_OK host.Number)) - - (import: Fs - (constants FsConstants) - (readFileSync [host.String] #try Binary) - (appendFileSync [host.String Buffer] #try Any) - (writeFileSync [host.String Buffer] #try Any) - (statSync [host.String] #try Stats) - (accessSync [host.String host.Number] #try Any) - (renameSync [host.String host.String] #try Any) - (utimesSync [host.String host.Number host.Number] #try Any) - (unlink [host.String] #try Any) - (readdirSync [host.String] #try (Array host.String)) - (mkdirSync [host.String] #try Any) - (rmdirSync [host.String] #try Any)) - - (import: JsPath - (sep host.String) - (basename [host.String] host.String)) - - (import: (#static require [host.String] Any)) - - (template: (!fs) - (:coerce ..Fs (..require "fs"))) - - (structure: (file path) + (`` (structure: (file path) + (-> Path (File IO)) + + (~~ (template [<name> <flag>] + [(def: <name> + (..can-modify + (function (<name> data) + (do (try.with io.monad) + [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>) + _ (java/io/OutputStream::write data stream) + _ (java/io/OutputStream::flush stream)] + (java/lang/AutoCloseable::close stream)))))] + + [over-write #0] + [append #1] + )) + + (def: content + (..can-query + (function (content _) + (do (try.with io.monad) + [#let [file (java/io/File::new path)] + size (java/io/File::length file) + #let [data (binary.create (.nat size))] + stream (java/io/FileInputStream::new file) + bytes-read (java/io/InputStream::read data stream) + _ (java/lang/AutoCloseable::close stream)] + (if (i.= size bytes-read) + (wrap data) + (io.io (exception.throw cannot-read-all-data path))))))) + + (def: name + (..can-see + (function (name _) + (|> path + java/io/File::new + java/io/File::getName)))) + + (def: path + (..can-see + (function (_ _) + path))) + + (def: size + (..can-query + (function (size _) + (|> path + java/io/File::new + java/io/File::length + (:: (try.with io.monad) map .nat))))) + + (def: last-modified + (..can-query + (function (last-modified _) + (|> path + java/io/File::new + (java/io/File::lastModified) + (:: (try.with io.monad) map (|>> duration.from-millis instant.absolute)))))) + + (def: can-execute? + (..can-query + (function (can-execute? _) + (|> path + java/io/File::new + java/io/File::canExecute)))) + + (def: move + (..can-open + (function (move destination) + (do io.monad + [outcome (java/io/File::renameTo (java/io/File::new destination) + (java/io/File::new path))] + (case outcome + (#try.Success #1) + (wrap (#try.Success (file destination))) + + _ + (io.io (exception.throw cannot-move [destination path]))))))) + + (def: modify + (..can-modify + (function (modify time-stamp) + (do io.monad + [outcome (java/io/File::setLastModified (|> time-stamp instant.relative duration.to-millis) + (java/io/File::new path))] + (case outcome + (#try.Success #1) + (wrap (#try.Success [])) + + _ + (io.io (exception.throw cannot-modify [time-stamp path]))))))) + + (def: delete + (..can-delete + (function (delete _) + (!delete path cannot-delete-file)))))) + + (`` (structure: (directory path) + (-> Path (Directory IO)) + + (~~ (template [<name> <method> <capability>] + [(def: <name> + (..can-query + (function (<name> _) + (do {@ (try.with io.monad)} + [?children (java/io/File::listFiles (java/io/File::new path))] + (case ?children + (#.Some children) + (|> children + array.to-list + (monad.filter @ (|>> <method>)) + (:: @ map (monad.map @ (|>> java/io/File::getAbsolutePath (:: @ map <capability>)))) + (:: @ join)) + + #.None + (io.io (exception.throw not-a-directory [path])))))))] + + [files java/io/File::isFile file] + [directories java/io/File::isDirectory directory] + )) + + (def: discard + (..can-delete + (function (discard _) + (!delete path cannot-discard-directory)))))) + + (`` (structure: #export system + (System IO) + + (~~ (template [<name> <method> <capability> <exception>] + [(def: <name> + (..can-open + (function (<name> path) + (do io.monad + [#let [file (java/io/File::new path)] + outcome (<method> file)] + (case outcome + (#try.Success #1) + (wrap (#try.Success (<capability> path))) + + _ + (wrap (exception.throw <exception> [path])))))))] + + [file java/io/File::isFile ..file cannot-find-file] + [create-file java/io/File::createNewFile ..file cannot-create-file] + [directory java/io/File::isDirectory ..directory cannot-find-directory] + [create-directory java/io/File::mkdir ..directory cannot-create-directory] + )) + + (def: separator (java/io/File::separator)) + )))] + (for {@.old + (as-is <for-jvm>) + + @.jvm + (as-is <for-jvm>) + + @.js + (as-is (import: Buffer + (#static from [Binary] ..Buffer)) + + (import: FileDescriptor) + + (import: Stats + (size host.Number) + (mtimeMs host.Number) + (isFile [] #try host.Boolean) + (isDirectory [] #try host.Boolean)) + + (import: FsConstants + (F_OK host.Number) + (R_OK host.Number) + (W_OK host.Number) + (X_OK host.Number)) + + (import: Fs + (constants FsConstants) + (readFileSync [host.String] #try Binary) + (appendFileSync [host.String Buffer] #try Any) + (writeFileSync [host.String Buffer] #try Any) + (statSync [host.String] #try Stats) + (accessSync [host.String host.Number] #try Any) + (renameSync [host.String host.String] #try Any) + (utimesSync [host.String host.Number host.Number] #try Any) + (unlink [host.String] #try Any) + (readdirSync [host.String] #try (Array host.String)) + (mkdirSync [host.String] #try Any) + (rmdirSync [host.String] #try Any)) + + (import: JsPath + (sep host.String) + (basename [host.String] host.String)) + + (import: (#static require [host.String] Any)) + + (template: (!fs) + (:coerce ..Fs (..require "fs"))) + + (`` (structure: (file path) (-> Path (File IO)) (~~ (template [<name> <method>] @@ -532,9 +532,9 @@ (def: delete (..can-delete (function (delete _) - (io.io (Fs::unlink [path] (!fs))))))) + (io.io (Fs::unlink [path] (!fs)))))))) - (structure: (directory path) + (`` (structure: (directory path) (-> Path (Directory IO)) (~~ (template [<name> <method> <capability>] @@ -561,9 +561,9 @@ (def: discard (..can-delete (function (discard _) - (io.io (Fs::rmdirSync [path] (!fs))))))) + (io.io (Fs::rmdirSync [path] (!fs)))))))) - (structure: #export system + (`` (structure: #export system (System IO) (~~ (template [<name> <method> <capability> <exception>] @@ -605,9 +605,9 @@ (:coerce JsPath) JsPath::sep) "/")) - ) - ) - }))) + )) + ) + })) (template [<get> <signature> <create> <find> <exception>] [(def: #export (<get> monad system path) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 14360da93..e2d9fb258 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -315,10 +315,10 @@ on-default))) (_.test "Can pick code depending on the host/platform being targeted." (n.= on-valid-host - (`` (for {(~~ (static @.old)) on-valid-host - (~~ (static @.jvm)) on-valid-host - (~~ (static @.js)) on-valid-host} - on-default))))))) + (for {@.old on-valid-host + @.jvm on-valid-host + @.js on-valid-host} + on-default)))))) (def: test (<| (_.context (name.module (name-of /._))) diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 702ea2272..da6f89187 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -36,53 +36,53 @@ (def: my-directive "my directive") ## Generation -(`` (for {(~~ (static @.old)) - (as-is)} - - (as-is (analysis: (..my-generation self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) +(for {@.old + (as-is)} + + (as-is (analysis: (..my-generation self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [_ (type.infer .Text)] + (wrap (#analysis.Extension self (list))))) - (synthesis: (..my-generation self phase archive {parameters (<>.some <a>.any)}) - (do phase.monad - [] - (wrap (#synthesis.Extension self (list))))) - ))) + (synthesis: (..my-generation self phase archive {parameters (<>.some <a>.any)}) + (do phase.monad + [] + (wrap (#synthesis.Extension self (list))))) + )) -(`` (for {(~~ (static @.jvm)) - (as-is (generation: (..my-generation self phase archive {parameters (<>.some <s>.any)}) - (do phase.monad - [] - (wrap (row.row (#jvm.Constant (#jvm.LDC (#jvm.String self))))))))})) +(for {@.jvm + (as-is (generation: (..my-generation self phase archive {parameters (<>.some <s>.any)}) + (do phase.monad + [] + (wrap (row.row (#jvm.Constant (#jvm.LDC (#jvm.String self))))))))}) -(`` (for {(~~ (static @.old)) - (as-is)} - - (as-is (analysis: (..my-analysis self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Primitive (#analysis.Text self))))) +(for {@.old + (as-is)} + + (as-is (analysis: (..my-analysis self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [_ (type.infer .Text)] + (wrap (#analysis.Primitive (#analysis.Text self))))) - ## Synthesis - (analysis: (..my-synthesis self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) + ## Synthesis + (analysis: (..my-synthesis self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [_ (type.infer .Text)] + (wrap (#analysis.Extension self (list))))) - (synthesis: (..my-synthesis self phase archive {parameters (<>.some <a>.any)}) - (do phase.monad - [] - (wrap (synthesis.text self)))) - - ## Directive - (directive: (..my-directive self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [#let [_ (log! (format "Successfully installed directive " (%.text self) "!"))]] - (wrap directive.no-requirements))) + (synthesis: (..my-synthesis self phase archive {parameters (<>.some <a>.any)}) + (do phase.monad + [] + (wrap (synthesis.text self)))) + + ## Directive + (directive: (..my-directive self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [#let [_ (log! (format "Successfully installed directive " (%.text self) "!"))]] + (wrap directive.no-requirements))) - (`` ((~~ (static ..my-directive)))) - ))) + (`` ((~~ (static ..my-directive)))) + )) (def: #export test Test @@ -90,10 +90,10 @@ (`` ($_ _.and (~~ (template [<macro> <extension>] [(_.cover [<macro>] - (`` (for {(~~ (static @.old)) - false} - (text@= ((~~ (static <extension>))) - <extension>))))] + (for {@.old + false} + (text@= (`` ((~~ (static <extension>)))) + <extension>)))] [/.analysis: ..my-analysis] [/.synthesis: ..my-synthesis] diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 6abfdb92d..f572b7e1e 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -288,38 +288,39 @@ #random ..$String::random #literal ..$String::literal}) -(`` (with-expansions [<comparison> (for {(~~ (static @.old)) - "jvm leq" - (~~ (static @.jvm)) - "jvm long ="})] - (template [<name> <bits> <type> <push> <wrap> <message> <to-long> <unsigned>] - [(def: <name> - Test - (do {@ random.monad} - [expected (:: @ map (i64.and (i64.mask <bits>)) random.nat)] - (<| (_.lift <message>) - (..bytecode (for {(~~ (static @.old)) - (|>> (:coerce <type>) <to-long> (<comparison> expected)) - (~~ (static @.jvm)) - (|>> (:coerce <type>) <to-long> "jvm object cast" (<comparison> ("jvm object cast" (:coerce java/lang/Long expected))))})) - (do /.monad - [_ (<push> (|> expected <unsigned> try.assume))] - <wrap>))))] +(with-expansions [<comparison> (for {@.old + "jvm leq" + @.jvm + "jvm long ="})] + (template [<name> <bits> <type> <push> <wrap> <message> <to-long> <unsigned>] + [(def: <name> + Test + (do {@ random.monad} + [expected (:: @ map (i64.and (i64.mask <bits>)) random.nat)] + (<| (_.lift <message>) + (..bytecode (for {@.old + (|>> (:coerce <type>) <to-long> (<comparison> expected)) + @.jvm + (|>> (:coerce <type>) <to-long> "jvm object cast" (<comparison> ("jvm object cast" (:coerce java/lang/Long expected))))})) + (do /.monad + [_ (<push> (|> expected <unsigned> try.assume))] + <wrap>))))] - [byte 7 java/lang/Byte /.bipush ..$Byte::wrap "BIPUSH" host.byte-to-long /unsigned.u1] - [short 15 java/lang/Short /.sipush ..$Short::wrap "SIPUSH" host.short-to-long /unsigned.u2] - ))) + [byte 7 java/lang/Byte /.bipush ..$Byte::wrap "BIPUSH" host.byte-to-long /unsigned.u1] + [short 15 java/lang/Short /.sipush ..$Short::wrap "SIPUSH" host.short-to-long /unsigned.u2] + )) (template [<name> <type>] - [(`` (template: (<name> <old-extension> <new-extension>) - (: (-> <type> <type> <type>) - (function (_ parameter subject) - (for {(~~ (static @.old)) - (<old-extension> subject parameter) - (~~ (static @.jvm)) - ("jvm object cast" - (<new-extension> ("jvm object cast" subject) - ("jvm object cast" parameter)))})))))] + [(template: (<name> <old-extension> <new-extension>) + (: (-> <type> <type> <type>) + (function (_ parameter subject) + (for {@.old + (<old-extension> subject parameter) + + @.jvm + ("jvm object cast" + (<new-extension> ("jvm object cast" subject) + ("jvm object cast" parameter)))}))))] [int/2 java/lang/Integer] [long/2 java/lang/Long] @@ -327,32 +328,32 @@ [double/2 java/lang/Double] ) -(`` (template: (long+int/2 <old-extension> <new-extension>) - (: (-> java/lang/Integer java/lang/Long java/lang/Long) - (function (_ parameter subject) - (for {(~~ (static @.old)) - (<old-extension> subject parameter) - (~~ (static @.jvm)) - ("jvm object cast" - (<new-extension> ("jvm object cast" subject) - ("jvm object cast" parameter)))}))))) +(template: (long+int/2 <old-extension> <new-extension>) + (: (-> java/lang/Integer java/lang/Long java/lang/Long) + (function (_ parameter subject) + (for {@.old + (<old-extension> subject parameter) + + @.jvm + ("jvm object cast" + (<new-extension> ("jvm object cast" subject) + ("jvm object cast" parameter)))})))) (def: int Test - (let [int (`` (with-expansions [<comparison> (for {(~~ (static @.old)) - "jvm ieq" - (~~ (static @.jvm)) - "jvm int ="})] - (: (-> java/lang/Integer (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Integer) (<comparison> expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Integer) "jvm object cast" - (<comparison> ("jvm object cast" expected)))}))) - (do /.monad - [_ bytecode] - ..$Integer::wrap)))))) + (let [int (with-expansions [<comparison> (for {@.old "jvm ieq" + @.jvm "jvm int ="})] + (: (-> java/lang/Integer (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce java/lang/Integer) (<comparison> expected)) + + @.jvm + (|>> (:coerce java/lang/Integer) "jvm object cast" + (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ bytecode] + ..$Integer::wrap))))) unary (: (-> (-> java/lang/Integer java/lang/Integer) (Bytecode Any) (Random Bit)) (function (_ reference instruction) (do random.monad @@ -424,291 +425,295 @@ (def: long Test - (`` (with-expansions [<comparison> (for {(~~ (static @.old)) - "jvm leq" - (~~ (static @.jvm)) - "jvm long ="})] - (let [long (: (-> java/lang/Long (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce Int) (i.= expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) - (do /.monad - [_ bytecode] - ..$Long::wrap)))) - unary (: (-> (-> java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [subject ..$Long::random] - (long (reference subject) - (do /.monad - [_ (..$Long::literal subject)] - instruction))))) - binary (: (-> (-> java/lang/Long java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [parameter ..$Long::random - subject ..$Long::random] - (long (reference parameter subject) - (do /.monad - [_ (..$Long::literal subject) - _ (..$Long::literal parameter)] - instruction))))) - shift (: (-> (-> java/lang/Integer java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do {@ random.monad} - [parameter (:: @ map (|>> (n.% 64) (:coerce java/lang/Long)) random.nat) - subject ..$Long::random] - (long (reference (host.long-to-int parameter) subject) - (do /.monad - [_ (..$Long::literal subject) - _ (..$Integer::literal (host.long-to-int parameter))] - instruction))))) - literal ($_ _.and - (_.lift "LCONST_0" (long (:coerce java/lang/Long +0) /.lconst-0)) - (_.lift "LCONST_1" (long (:coerce java/lang/Long +1) /.lconst-1)) - (_.lift "LDC2_W/LONG" - (do random.monad - [expected ..$Long::random] - (long expected (..$Long::literal expected))))) - arithmetic ($_ _.and - (_.lift "LADD" (binary (long/2 "jvm ladd" "jvm long +") /.ladd)) - (_.lift "LSUB" (binary (long/2 "jvm lsub" "jvm long -") /.lsub)) - (_.lift "LMUL" (binary (long/2 "jvm lmul" "jvm long *") /.lmul)) - (_.lift "LDIV" (binary (long/2 "jvm ldiv" "jvm long /") /.ldiv)) - (_.lift "LREM" (binary (long/2 "jvm lrem" "jvm long %") /.lrem)) - (_.lift "LNEG" (unary (function (_ value) - ((long/2 "jvm lsub" "jvm long -") - value - (:coerce java/lang/Long +0))) - /.lneg))) - bitwise ($_ _.and - (_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land)) - (_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor)) - (_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor)) - (_.lift "LSHL" (shift (long+int/2 "jvm lshl" "jvm long shl") /.lshl)) - (_.lift "LSHR" (shift (long+int/2 "jvm lshr" "jvm long shr") /.lshr)) - (_.lift "LUSHR" (shift (long+int/2 "jvm lushr" "jvm long ushr") /.lushr))) - comparison (_.lift "LCMP" - (do random.monad - [reference ..$Long::random - subject ..$Long::random - #let [expected (cond (i.= (:coerce Int reference) (:coerce Int subject)) - (:coerce java/lang/Long +0) + (with-expansions [<comparison> (for {@.old "jvm leq" + @.jvm "jvm long ="})] + (let [long (: (-> java/lang/Long (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce Int) (i.= expected)) + + @.jvm + (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ bytecode] + ..$Long::wrap)))) + unary (: (-> (-> java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [subject ..$Long::random] + (long (reference subject) + (do /.monad + [_ (..$Long::literal subject)] + instruction))))) + binary (: (-> (-> java/lang/Long java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [parameter ..$Long::random + subject ..$Long::random] + (long (reference parameter subject) + (do /.monad + [_ (..$Long::literal subject) + _ (..$Long::literal parameter)] + instruction))))) + shift (: (-> (-> java/lang/Integer java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do {@ random.monad} + [parameter (:: @ map (|>> (n.% 64) (:coerce java/lang/Long)) random.nat) + subject ..$Long::random] + (long (reference (host.long-to-int parameter) subject) + (do /.monad + [_ (..$Long::literal subject) + _ (..$Integer::literal (host.long-to-int parameter))] + instruction))))) + literal ($_ _.and + (_.lift "LCONST_0" (long (:coerce java/lang/Long +0) /.lconst-0)) + (_.lift "LCONST_1" (long (:coerce java/lang/Long +1) /.lconst-1)) + (_.lift "LDC2_W/LONG" + (do random.monad + [expected ..$Long::random] + (long expected (..$Long::literal expected))))) + arithmetic ($_ _.and + (_.lift "LADD" (binary (long/2 "jvm ladd" "jvm long +") /.ladd)) + (_.lift "LSUB" (binary (long/2 "jvm lsub" "jvm long -") /.lsub)) + (_.lift "LMUL" (binary (long/2 "jvm lmul" "jvm long *") /.lmul)) + (_.lift "LDIV" (binary (long/2 "jvm ldiv" "jvm long /") /.ldiv)) + (_.lift "LREM" (binary (long/2 "jvm lrem" "jvm long %") /.lrem)) + (_.lift "LNEG" (unary (function (_ value) + ((long/2 "jvm lsub" "jvm long -") + value + (:coerce java/lang/Long +0))) + /.lneg))) + bitwise ($_ _.and + (_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land)) + (_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor)) + (_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor)) + (_.lift "LSHL" (shift (long+int/2 "jvm lshl" "jvm long shl") /.lshl)) + (_.lift "LSHR" (shift (long+int/2 "jvm lshr" "jvm long shr") /.lshr)) + (_.lift "LUSHR" (shift (long+int/2 "jvm lushr" "jvm long ushr") /.lushr))) + comparison (_.lift "LCMP" + (do random.monad + [reference ..$Long::random + subject ..$Long::random + #let [expected (cond (i.= (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long +0) - (i.> (:coerce Int reference) (:coerce Int subject)) - (:coerce java/lang/Long +1) + (i.> (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long +1) - ## (i.< (:coerce Int reference) (:coerce Int subject)) - (:coerce java/lang/Long -1))]] - (<| (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce Int) (i.= expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) - (do /.monad - [_ (..$Long::literal subject) - _ (..$Long::literal reference) - _ /.lcmp - _ /.i2l] - ..$Long::wrap))))] - ($_ _.and - (<| (_.context "literal") - literal) - (<| (_.context "arithmetic") - arithmetic) - (<| (_.context "bitwise") - bitwise) - (<| (_.context "comparison") - comparison) - ))))) + ## (i.< (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long -1))]] + (<| (..bytecode (for {@.old + (|>> (:coerce Int) (i.= expected)) + + @.jvm + (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ (..$Long::literal subject) + _ (..$Long::literal reference) + _ /.lcmp + _ /.i2l] + ..$Long::wrap))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "bitwise") + bitwise) + (<| (_.context "comparison") + comparison) + )))) (def: float Test - (`` (with-expansions [<comparison> (for {(~~ (static @.old)) - "jvm feq" - (~~ (static @.jvm)) - "jvm float ="})] - (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Float) ("jvm feq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Float) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) - (do /.monad - [_ bytecode] - ..$Float::wrap)))) - unary (: (-> (-> java/lang/Float java/lang/Float) - (Bytecode Any) - (Random Bit)) - (function (_ reference instruction) - (do random.monad - [subject ..$Float::random] - (float (reference subject) - (do /.monad - [_ (..$Float::literal subject)] - instruction))))) - binary (: (-> (-> java/lang/Float java/lang/Float java/lang/Float) - (Bytecode Any) - (Random Bit)) - (function (_ reference instruction) - (do random.monad - [parameter ..$Float::random - subject ..$Float::random] - (float (reference parameter subject) - (do /.monad - [_ (..$Float::literal subject) - _ (..$Float::literal parameter)] - instruction))))) - literal ($_ _.and - (_.lift "FCONST_0" (float (host.double-to-float (:coerce java/lang/Double +0.0)) /.fconst-0)) - (_.lift "FCONST_1" (float (host.double-to-float (:coerce java/lang/Double +1.0)) /.fconst-1)) - (_.lift "FCONST_2" (float (host.double-to-float (:coerce java/lang/Double +2.0)) /.fconst-2)) - (_.lift "LDC_W/FLOAT" - (do random.monad - [expected ..$Float::random] - (float expected (..$Float::literal expected))))) - arithmetic ($_ _.and - (_.lift "FADD" (binary (float/2 "jvm fadd" "jvm float +") /.fadd)) - (_.lift "FSUB" (binary (float/2 "jvm fsub" "jvm float -") /.fsub)) - (_.lift "FMUL" (binary (float/2 "jvm fmul" "jvm float *") /.fmul)) - (_.lift "FDIV" (binary (float/2 "jvm fdiv" "jvm float /") /.fdiv)) - (_.lift "FREM" (binary (float/2 "jvm frem" "jvm float %") /.frem)) - (_.lift "FNEG" (unary (function (_ value) - ((float/2 "jvm fsub" "jvm float -") - value - (host.double-to-float (:coerce java/lang/Double +0.0)))) - /.fneg))) - comparison (: (-> (Bytecode Any) (-> java/lang/Float java/lang/Float Bit) (Random Bit)) - (function (_ instruction standard) + (with-expansions [<comparison> (for {@.old "jvm feq" + @.jvm "jvm float ="})] + (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce java/lang/Float) ("jvm feq" expected)) + + @.jvm + (|>> (:coerce java/lang/Float) "jvm object cast" (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ bytecode] + ..$Float::wrap)))) + unary (: (-> (-> java/lang/Float java/lang/Float) + (Bytecode Any) + (Random Bit)) + (function (_ reference instruction) + (do random.monad + [subject ..$Float::random] + (float (reference subject) + (do /.monad + [_ (..$Float::literal subject)] + instruction))))) + binary (: (-> (-> java/lang/Float java/lang/Float java/lang/Float) + (Bytecode Any) + (Random Bit)) + (function (_ reference instruction) + (do random.monad + [parameter ..$Float::random + subject ..$Float::random] + (float (reference parameter subject) + (do /.monad + [_ (..$Float::literal subject) + _ (..$Float::literal parameter)] + instruction))))) + literal ($_ _.and + (_.lift "FCONST_0" (float (host.double-to-float (:coerce java/lang/Double +0.0)) /.fconst-0)) + (_.lift "FCONST_1" (float (host.double-to-float (:coerce java/lang/Double +1.0)) /.fconst-1)) + (_.lift "FCONST_2" (float (host.double-to-float (:coerce java/lang/Double +2.0)) /.fconst-2)) + (_.lift "LDC_W/FLOAT" (do random.monad - [reference ..$Float::random - subject ..$Float::random - #let [expected (if (`` (for {(~~ (static @.old)) - ("jvm feq" reference subject) - (~~ (static @.jvm)) - (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))})) - +0 - (if (standard reference subject) - +1 - -1))]] - (<| (..bytecode (|>> (:coerce Int) (i.= expected))) - (do /.monad - [_ (..$Float::literal subject) - _ (..$Float::literal reference) - _ instruction - _ /.i2l] - ..$Long::wrap))))) - comparison ($_ _.and - (_.lift "FCMPL" (comparison /.fcmpl (function (_ reference subject) - (`` (for {(~~ (static @.old)) - ("jvm fgt" subject reference) - (~~ (static @.jvm)) - ("jvm float <" ("jvm object cast" reference) ("jvm object cast" subject))}))))) - (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject) - (`` (for {(~~ (static @.old)) - ("jvm fgt" subject reference) - (~~ (static @.jvm)) - ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))}))))))] - ($_ _.and - (<| (_.context "literal") - literal) - (<| (_.context "arithmetic") - arithmetic) - (<| (_.context "comparison") - comparison) - ))))) + [expected ..$Float::random] + (float expected (..$Float::literal expected))))) + arithmetic ($_ _.and + (_.lift "FADD" (binary (float/2 "jvm fadd" "jvm float +") /.fadd)) + (_.lift "FSUB" (binary (float/2 "jvm fsub" "jvm float -") /.fsub)) + (_.lift "FMUL" (binary (float/2 "jvm fmul" "jvm float *") /.fmul)) + (_.lift "FDIV" (binary (float/2 "jvm fdiv" "jvm float /") /.fdiv)) + (_.lift "FREM" (binary (float/2 "jvm frem" "jvm float %") /.frem)) + (_.lift "FNEG" (unary (function (_ value) + ((float/2 "jvm fsub" "jvm float -") + value + (host.double-to-float (:coerce java/lang/Double +0.0)))) + /.fneg))) + comparison (: (-> (Bytecode Any) (-> java/lang/Float java/lang/Float Bit) (Random Bit)) + (function (_ instruction standard) + (do random.monad + [reference ..$Float::random + subject ..$Float::random + #let [expected (if (for {@.old + ("jvm feq" reference subject) + + @.jvm + (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))}) + +0 + (if (standard reference subject) + +1 + -1))]] + (<| (..bytecode (|>> (:coerce Int) (i.= expected))) + (do /.monad + [_ (..$Float::literal subject) + _ (..$Float::literal reference) + _ instruction + _ /.i2l] + ..$Long::wrap))))) + comparison ($_ _.and + (_.lift "FCMPL" (comparison /.fcmpl (function (_ reference subject) + (for {@.old + ("jvm fgt" subject reference) + + @.jvm + ("jvm float <" ("jvm object cast" reference) ("jvm object cast" subject))})))) + (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject) + (for {@.old + ("jvm fgt" subject reference) + + @.jvm + ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "comparison") + comparison) + )))) (def: double Test - (`` (with-expansions [<comparison> (for {(~~ (static @.old)) - "jvm deq" - (~~ (static @.jvm)) - "jvm double ="})] - (let [double (: (-> java/lang/Double (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Double) ("jvm deq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Double) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) - (do /.monad - [_ bytecode] - ..$Double::wrap)))) - unary (: (-> (-> java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [subject ..$Double::random] - (double (reference subject) - (do /.monad - [_ (..$Double::literal subject)] - instruction))))) - binary (: (-> (-> java/lang/Double java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [parameter ..$Double::random - subject ..$Double::random] - (double (reference parameter subject) - (do /.monad - [_ (..$Double::literal subject) - _ (..$Double::literal parameter)] - instruction))))) - literal ($_ _.and - (_.lift "DCONST_0" (double (:coerce java/lang/Double +0.0) /.dconst-0)) - (_.lift "DCONST_1" (double (:coerce java/lang/Double +1.0) /.dconst-1)) - (_.lift "LDC2_W/DOUBLE" - (do random.monad - [expected ..$Double::random] - (double expected (..$Double::literal expected))))) - arithmetic ($_ _.and - (_.lift "DADD" (binary (double/2 "jvm dadd" "jvm double +") /.dadd)) - (_.lift "DSUB" (binary (double/2 "jvm dsub" "jvm double -") /.dsub)) - (_.lift "DMUL" (binary (double/2 "jvm dmul" "jvm double *") /.dmul)) - (_.lift "DDIV" (binary (double/2 "jvm ddiv" "jvm double /") /.ddiv)) - (_.lift "DREM" (binary (double/2 "jvm drem" "jvm double %") /.drem)) - (_.lift "DNEG" (unary (function (_ value) - ((double/2 "jvm dsub" "jvm double -") - value - (:coerce java/lang/Double +0.0))) - /.dneg))) - comparison (: (-> (Bytecode Any) (-> java/lang/Double java/lang/Double Bit) (Random Bit)) - (function (_ instruction standard) + (with-expansions [<comparison> (for {@.old "jvm deq" + @.jvm "jvm double ="})] + (let [double (: (-> java/lang/Double (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ bytecode] + ..$Double::wrap)))) + unary (: (-> (-> java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [subject ..$Double::random] + (double (reference subject) + (do /.monad + [_ (..$Double::literal subject)] + instruction))))) + binary (: (-> (-> java/lang/Double java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [parameter ..$Double::random + subject ..$Double::random] + (double (reference parameter subject) + (do /.monad + [_ (..$Double::literal subject) + _ (..$Double::literal parameter)] + instruction))))) + literal ($_ _.and + (_.lift "DCONST_0" (double (:coerce java/lang/Double +0.0) /.dconst-0)) + (_.lift "DCONST_1" (double (:coerce java/lang/Double +1.0) /.dconst-1)) + (_.lift "LDC2_W/DOUBLE" (do random.monad - [reference ..$Double::random - subject ..$Double::random - #let [expected (if (`` (for {(~~ (static @.old)) - ("jvm deq" reference subject) - (~~ (static @.jvm)) - (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))})) - +0 - (if (standard reference subject) - +1 - -1))]] - (<| (..bytecode (|>> (:coerce Int) (i.= expected))) - (do /.monad - [_ (..$Double::literal subject) - _ (..$Double::literal reference) - _ instruction - _ /.i2l] - ..$Long::wrap))))) - comparison ($_ _.and - (_.lift "DCMPL" (comparison /.dcmpl (function (_ reference subject) - (`` (for {(~~ (static @.old)) - ("jvm dlt" subject reference) - (~~ (static @.jvm)) - ("jvm double <" ("jvm object cast" reference) ("jvm object cast" subject))}))))) - (_.lift "DCMPG" (comparison /.dcmpg (function (_ reference subject) - (`` (for {(~~ (static @.old)) - ("jvm dgt" subject reference) - (~~ (static @.jvm)) - ("jvm double <" ("jvm object cast" subject) ("jvm object cast" reference))}))))))] - ($_ _.and - (<| (_.context "literal") - literal) - (<| (_.context "arithmetic") - arithmetic) - (<| (_.context "comparison") - comparison) - ))))) + [expected ..$Double::random] + (double expected (..$Double::literal expected))))) + arithmetic ($_ _.and + (_.lift "DADD" (binary (double/2 "jvm dadd" "jvm double +") /.dadd)) + (_.lift "DSUB" (binary (double/2 "jvm dsub" "jvm double -") /.dsub)) + (_.lift "DMUL" (binary (double/2 "jvm dmul" "jvm double *") /.dmul)) + (_.lift "DDIV" (binary (double/2 "jvm ddiv" "jvm double /") /.ddiv)) + (_.lift "DREM" (binary (double/2 "jvm drem" "jvm double %") /.drem)) + (_.lift "DNEG" (unary (function (_ value) + ((double/2 "jvm dsub" "jvm double -") + value + (:coerce java/lang/Double +0.0))) + /.dneg))) + comparison (: (-> (Bytecode Any) (-> java/lang/Double java/lang/Double Bit) (Random Bit)) + (function (_ instruction standard) + (do random.monad + [reference ..$Double::random + subject ..$Double::random + #let [expected (if (for {@.old + ("jvm deq" reference subject) + + @.jvm + (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))}) + +0 + (if (standard reference subject) + +1 + -1))]] + (<| (..bytecode (|>> (:coerce Int) (i.= expected))) + (do /.monad + [_ (..$Double::literal subject) + _ (..$Double::literal reference) + _ instruction + _ /.i2l] + ..$Long::wrap))))) + comparison ($_ _.and + (_.lift "DCMPL" (comparison /.dcmpl (function (_ reference subject) + (for {@.old + ("jvm dlt" subject reference) + + @.jvm + ("jvm double <" ("jvm object cast" reference) ("jvm object cast" subject))})))) + (_.lift "DCMPG" (comparison /.dcmpg (function (_ reference subject) + (for {@.old + ("jvm dgt" subject reference) + + @.jvm + ("jvm double <" ("jvm object cast" subject) ("jvm object cast" reference))})))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "comparison") + comparison) + )))) (def: primitive Test @@ -774,10 +779,11 @@ (<| (_.lift "INVOKESTATIC") (do random.monad [expected ..$Double::random]) - (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Double) ("jvm deq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))}))) + (..bytecode (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))})) (do /.monad [_ (/.double (:coerce Frac expected))] (/.invokestatic ..$Double "valueOf" (/type.method [(list /type.double) ..$Double (list)])))) @@ -793,10 +799,11 @@ (<| (_.lift "INVOKESPECIAL") (do random.monad [expected ..$Double::random]) - (..bytecode (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Double) ("jvm deq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))}))) + (..bytecode (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))})) (do /.monad [_ (/.new ..$Double) _ /.dup @@ -820,11 +827,12 @@ part0 ..$Long::random part1 ..$Long::random #let [expected (: java/lang/Long - (`` (for {(~~ (static @.old)) - ("jvm ladd" part0 part1) - (~~ (static @.jvm)) - ("jvm object cast" - ("jvm long +" ("jvm object cast" part0) ("jvm object cast" part1)))}))) + (for {@.old + ("jvm ladd" part0 part1) + + @.jvm + ("jvm object cast" + ("jvm long +" ("jvm object cast" part0) ("jvm object cast" part1)))})) $Self (/type.class class-name (list)) class-field "class_field" object-field "object_field" @@ -938,52 +946,59 @@ (_.context "byte" (array (/.newarray /instruction.t-byte) $Byte::random $Byte::literal [/.bastore /.baload $Byte::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Byte) host.byte-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.byte-to-long (:coerce java/lang/Byte expected)))))}))))) + (for {@.old + (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) + + @.jvm + (|>> (:coerce java/lang/Byte) host.byte-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.byte-to-long (:coerce java/lang/Byte expected)))))})))) (_.context "short" (array (/.newarray /instruction.t-short) $Short::random $Short::literal [/.sastore /.saload $Short::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Short) host.short-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.short-to-long (:coerce java/lang/Short expected)))))}))))) + (for {@.old + (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) + + @.jvm + (|>> (:coerce java/lang/Short) host.short-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.short-to-long (:coerce java/lang/Short expected)))))})))) (_.context "int" (array (/.newarray /instruction.t-int) $Integer::random $Integer::literal [/.iastore /.iaload $Integer::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Integer) ("jvm ieq" (host.int-to-long expected))) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Integer) "jvm object cast" ("jvm int =" ("jvm object cast" (:coerce java/lang/Integer expected))))}))))) + (for {@.old + (|>> (:coerce java/lang/Integer) ("jvm ieq" (host.int-to-long expected))) + + @.jvm + (|>> (:coerce java/lang/Integer) "jvm object cast" ("jvm int =" ("jvm object cast" (:coerce java/lang/Integer expected))))})))) (_.context "long" (array (/.newarray /instruction.t-long) $Long::random $Long::literal [/.lastore /.laload $Long::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Long) ("jvm leq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Long) "jvm object cast" ("jvm long =" ("jvm object cast" (:coerce java/lang/Long expected))))}))))) + (for {@.old + (|>> (:coerce java/lang/Long) ("jvm leq" expected)) + + @.jvm + (|>> (:coerce java/lang/Long) "jvm object cast" ("jvm long =" ("jvm object cast" (:coerce java/lang/Long expected))))})))) (_.context "float" (array (/.newarray /instruction.t-float) $Float::random $Float::literal [/.fastore /.faload $Float::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Float) ("jvm feq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Float) "jvm object cast" ("jvm float =" ("jvm object cast" (:coerce java/lang/Float expected))))}))))) + (for {@.old + (|>> (:coerce java/lang/Float) ("jvm feq" expected)) + + @.jvm + (|>> (:coerce java/lang/Float) "jvm object cast" ("jvm float =" ("jvm object cast" (:coerce java/lang/Float expected))))})))) (_.context "double" (array (/.newarray /instruction.t-double) $Double::random $Double::literal [/.dastore /.daload $Double::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Double) ("jvm deq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" (:coerce java/lang/Double expected))))}))))) + (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" (:coerce java/lang/Double expected))))})))) (_.context "char" (array (/.newarray /instruction.t-char) $Character::random $Character::literal [/.castore /.caload $Character::wrap] (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Character) ("jvm ceq" expected)) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Character) "jvm object cast" ("jvm char =" ("jvm object cast" (:coerce java/lang/Character expected))))}))))) + (for {@.old + (|>> (:coerce java/lang/Character) ("jvm ceq" expected)) + + @.jvm + (|>> (:coerce java/lang/Character) "jvm object cast" ("jvm char =" ("jvm object cast" (:coerce java/lang/Character expected))))})))) (_.context "object" (array (/.anewarray ..$String) $String::random $String::literal [/.aastore /.aaload /.nop] (function (_ expected) (|>> (:coerce Text) (text@= (:coerce Text expected)))))) @@ -1013,10 +1028,11 @@ (template: (!::= <type> <old> <new>) (: (-> <type> Any Bit) (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce <type>) (<old> expected)) - (~~ (static @.jvm)) - (|>> (:coerce <type>) "jvm object cast" (<new> ("jvm object cast" (:coerce <type> expected))))}))))) + (for {@.old + (|>> (:coerce <type>) (<old> expected)) + + @.jvm + (|>> (:coerce <type>) "jvm object cast" (<new> ("jvm object cast" (:coerce <type> expected))))})))) (def: conversion Test @@ -1043,18 +1059,20 @@ (_.lift "I2D" (conversion ..$Integer::primitive ..$Double::primitive /.i2d (|>> host.int-to-double) double::=)) (_.lift "I2B" (conversion ..$Integer::primitive ..$Byte::primitive /.i2b (|>> host.int-to-byte) (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Byte) host.byte-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.byte-to-long (:coerce java/lang/Byte expected)))))}))))) + (for {@.old + (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) + + @.jvm + (|>> (:coerce java/lang/Byte) host.byte-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.byte-to-long (:coerce java/lang/Byte expected)))))})))) (_.lift "I2C" (conversion ..$Integer::primitive ..$Character::primitive /.i2c (|>> host.int-to-char) (!::= java/lang/Character "jvm ceq" "jvm char ="))) (_.lift "I2S" (conversion ..$Integer::primitive ..$Short::primitive /.i2s (|>> host.int-to-short) (function (_ expected) - (`` (for {(~~ (static @.old)) - (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) - (~~ (static @.jvm)) - (|>> (:coerce java/lang/Short) host.short-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.short-to-long (:coerce java/lang/Short expected)))))}))))))) + (for {@.old + (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) + + @.jvm + (|>> (:coerce java/lang/Short) host.short-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.short-to-long (:coerce java/lang/Short expected)))))})))))) (<| (_.context "long") ($_ _.and (_.lift "L2I" (conversion ..$Long::primitive ..$Integer::primitive /.l2i (|>> host.long-to-int) int::=)) @@ -1126,15 +1144,16 @@ increment (:: @ map (|>> (n.% 100) /unsigned.u1 try.assume) random.nat) #let [expected (: java/lang/Long - (`` (for {(~~ (static @.old)) - ("jvm ladd" - (host.byte-to-long base) - (.int (/unsigned.value increment))) - (~~ (static @.jvm)) - ("jvm object cast" - ("jvm long +" - ("jvm object cast" (host.byte-to-long base)) - ("jvm object cast" (:coerce java/lang/Long (/unsigned.value increment)))))})))]] + (for {@.old + ("jvm ladd" + (host.byte-to-long base) + (.int (/unsigned.value increment))) + + @.jvm + ("jvm object cast" + ("jvm long +" + ("jvm object cast" (host.byte-to-long base)) + ("jvm object cast" (:coerce java/lang/Long (/unsigned.value increment)))))}))]] (..bytecode (|>> (:coerce Int) (i.= (:coerce Int expected))) (do /.monad [_ (..$Byte::literal base) @@ -1385,10 +1404,11 @@ reference ..$Integer::random subject (|> ..$Integer::random (random.filter (|>> ((!::= java/lang/Integer "jvm ieq" "jvm int =") reference) not))) - #let [[lesser greater] (if (`` (for {(~~ (static @.old)) - ("jvm ilt" reference subject) - (~~ (static @.jvm)) - ("jvm int <" ("jvm object cast" subject) ("jvm object cast" reference))})) + #let [[lesser greater] (if (for {@.old + ("jvm ilt" reference subject) + + @.jvm + ("jvm int <" ("jvm object cast" subject) ("jvm object cast" reference))}) [reference subject] [subject reference]) int-comparison ($_ _.and |