diff options
Diffstat (limited to '')
13 files changed, 30 insertions, 374 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index ca0447548..f382c2ff3 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -233,50 +233,11 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list))))))) -(defn ^:private analyse-box-new [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] - =init (&&/analyse-1 analyse $var ?init) - _ (&type/check exo-type (&/$UnivQ (&/|list) (&type/Box (&/$Parameter 1) $var))) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["box" "new"]) (&/|list =init) (&/|list))))))))) - -(defn ^:private analyse-box-read [analyse exo-type ?values] - (&type/with-var - (fn [threadT] - (&type/with-var - (fn [valueT] - (|do [:let [(&/$Cons boxC (&/$Nil)) ?values] - boxA (&&/analyse-1 analyse (&type/Box threadT valueT) boxC) - _ (&type/check exo-type valueT) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["box" "read"]) (&/|list boxA) (&/|list))))))))))) - -(defn ^:private analyse-box-write [analyse exo-type ?values] - (&type/with-var - (fn [threadT] - (&type/with-var - (fn [valueT] - (|do [:let [(&/$Cons valueC (&/$Cons boxC (&/$Nil))) ?values] - boxA (&&/analyse-1 analyse (&type/Box threadT valueT) boxC) - valueA (&&/analyse-1 analyse valueT valueC) - _ (&type/check exo-type &type/Any) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["box" "write"]) (&/|list valueA boxA) (&/|list))))))))))) - (defn analyse-proc [analyse exo-type proc ?values] (try (case proc "lux is" (analyse-lux-is analyse exo-type ?values) "lux try" (analyse-lux-try analyse exo-type ?values) - "lux box new" (analyse-box-new analyse exo-type ?values) - "lux box read" (analyse-box-read analyse exo-type ?values) - "lux box write" (analyse-box-write analyse exo-type ?values) - "lux io log" (analyse-io-log analyse exo-type ?values) "lux io error" (analyse-io-error analyse exo-type ?values) "lux io exit" (analyse-io-exit analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 3f10bade1..444db63e3 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -374,47 +374,6 @@ &&/wrap-long)]] (return nil))) -(defn ^:private compile-box-new [compile ?values special-args] - (|do [:let [(&/$Cons initS (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int 1)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)))] - _ (compile initS) - :let [_ (doto *writer* - (.visitInsn Opcodes/AASTORE))]] - (return nil))) - -(defn ^:private compile-box-read [compile ?values special-args] - (|do [:let [(&/$Cons boxS (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile boxS) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD))]] - (return nil))) - -(defn ^:private compile-box-write [compile ?values special-args] - (|do [:let [(&/$Cons valueS (&/$Cons boxS (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile boxS) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int 0)))] - _ (compile valueS) - :let [_ (doto *writer* - (.visitInsn Opcodes/AASTORE) - (.visitLdcInsn &/unit-tag))]] - (return nil))) - (defn compile-proc [compile category proc ?values special-args] (case category "lux" @@ -480,12 +439,5 @@ "decode" (compile-frac-decode compile ?values special-args) ) - "box" - (case proc - "new" (compile-box-new compile ?values special-args) - "read" (compile-box-read compile ?values special-args) - "write" (compile-box-write compile ?values special-args) - ) - ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux index 91a95d2f9..b140a11eb 100644 --- a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux @@ -301,27 +301,6 @@ (install "exit" (unary runtimeT.io//exit)) (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time runtimeT.unit))))))) -## [[Box]] -(def: box//new - Unary - (|>> (list) _.vector)) - -(def: (box//read box) - Unary - (_.svref box (_.int 0))) - -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - ## [Bundles] (def: #export procedures Bundle @@ -332,5 +311,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux index 0efdedd4c..641eb9e02 100644 --- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux @@ -286,19 +286,6 @@ Nullary (frac//to-int "(new Date()).getTime()")) -## [[Box]] -(def: (box//new initJS) - Unary - (format "[" initJS "]")) - -(def: (box//read boxJS) - Unary - (format "(" boxJS ")[0]")) - -(def: (box//write [valueJS boxJS]) - Binary - (void (format (box//read boxJS) " = " valueJS))) - ## [Bundles] (def: lux-procs Bundle @@ -376,14 +363,6 @@ (install "exit" (unary io//exit)) (install "current-time" (nullary io//current-time))))) -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - (def: #export procedures Bundle (<| (prefix "lux") @@ -393,5 +372,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index 2c470c44c..809a13bb9 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -364,31 +364,6 @@ (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) #0) (_.wrap #$.Long))) -## [[Box]] -(def: empty-boxI - $.Inst - (|>> (_.int 1) (_.ANEWARRAY ($t.binary-name "java.lang.Object")))) - -(def: check-boxI - $.Inst - (_.CHECKCAST ($t.descriptor $Object-Array))) - -(def: (box//new initI) - Unary - (|>> empty-boxI - _.DUP (_.int 0) initI _.AASTORE)) - -(def: (box//read boxI) - Unary - (|>> boxI check-boxI - (_.int 0) _.AALOAD)) - -(def: (box//write [valueI boxI]) - Binary - (|>> boxI check-boxI - (_.int 0) valueI _.AASTORE - unitI)) - ## [Bundles] (def: lux-procs Bundle @@ -466,14 +441,6 @@ (install "exit" (unary io//exit)) (install "current-time" (nullary io//current-time))))) -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - (def: #export procedures Bundle (<| (prefix "lux") @@ -483,5 +450,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux index 394dd3d34..f173f24b6 100644 --- a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux @@ -285,19 +285,6 @@ (|> (lua.apply "os.time" (list)) (lua.* (lua.int 1_000)))) -## [[Box]] -(def: box//new - Unary - (|>> (list) lua.array)) - -(def: box//read - Unary - (lua.nth (lua.int 1))) - -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - ## [Bundles] (def: lux-procs Bundle @@ -375,14 +362,6 @@ (install "exit" (unary io//exit)) (install "current-time" (nullary io//current-time))))) -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - (def: #export procedures Bundle (<| (prefix "lux") @@ -392,5 +371,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux index 430d4b5e7..8ffe03f49 100644 --- a/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux @@ -328,27 +328,6 @@ (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time! runtimeT.unit))))))) -## [[Box]] -(def: box//new - Unary - (|>> (list) python.list)) - -(def: box//read - Unary - (python.nth (python.int 0))) - -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - ## [Bundles] (def: #export procedures Bundle @@ -359,5 +338,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux index 421618890..261e6cfb9 100644 --- a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux @@ -326,27 +326,6 @@ (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time! runtimeT.unit))))))) -## [[Box]] -(def: box//new - Unary - (|>> (list) r.list)) - -(def: box//read - Unary - (r.nth (r.int 1))) - -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - ## [Bundles] (def: #export procedures Bundle @@ -357,5 +336,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux index e40f49b80..9176879b1 100644 --- a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux @@ -359,27 +359,6 @@ (install "exit" (unary io//exit)) (install "current-time" (nullary io//current-time))))) -## [[Box]] -(def: box//new - Unary - (|>> (list) ruby.array)) - -(def: box//read - Unary - (ruby.nth (ruby.int 0))) - -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - ## [Bundles] (def: #export procedures Bundle @@ -390,5 +369,4 @@ (dict.merge frac-procs) (dict.merge text-procs) (dict.merge io-procs) - (dict.merge box-procs) ))) diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux index 03e56fa18..f03965de2 100644 --- a/new-luxc/test/test/luxc/lang/translation/common.lux +++ b/new-luxc/test/test/luxc/lang/translation/common.lux @@ -325,42 +325,6 @@ #0)))) ))) -(def: (box-spec run) - (-> Runner Test) - (do r.Monad<Random> - [pre r.nat - post (|> r.nat (r.filter (|>> (n/= pre) not))) - #let [preS (synthesis.i64 pre) - postS (synthesis.i64 post) - boxS (#synthesis.Extension "lux box new" - (list preS))]] - ($_ seq - (test "Can read boxes." - (|> (run (#synthesis.Extension "lux box read" (list boxS))) - (case> (#e.Success valueV) - (n/= pre (:coerce Nat valueV)) - - (#e.Error error) - (exec (log! error) - #0)))) - (test "Can write boxes." - (|> (run (synthesis.branch/let - [boxS - 0 - (synthesis.branch/let - [(#synthesis.Extension "lux box write" - (list postS (synthesis.variable/local 0))) - 1 - (#synthesis.Extension "lux box read" - (list (synthesis.variable/local 0)))])])) - (case> (#e.Success valueV) - (n/= post (:coerce Nat valueV)) - - (#e.Error error) - (exec (log! error) - #0)))) - ))) - (def: (all-specs run) (-> Runner Test) ($_ seq @@ -369,7 +333,6 @@ (f64-spec run) (text-spec run) (io-spec run) - (box-spec run) )) (context: "[JVM] Common procedures." diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux index 24f22df3c..bf8e73b86 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux @@ -2,8 +2,7 @@ [lux #* [control ["." monad (#+ do)] - ["ex" exception (#+ exception:)] - [thread (#+ Box)]] + ["ex" exception (#+ exception:)]] [data ["." text format] @@ -202,48 +201,6 @@ (bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) ))) -(def: box::new - Handler - (function (_ extension-name analyse args) - (case args - (^ (list initC)) - (do ////.Monad<Operation> - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer (type (All [!] (Box ! varT)))) - initA (typeA.with-type varT - (analyse initC))] - (wrap (#analysis.Extension extension-name (list initA)))) - - _ - (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: box::read - Handler - (function (_ extension-name analyse args) - (do ////.Monad<Operation> - [[thread-id threadT] (typeA.with-env check.var) - [var-id varT] (typeA.with-env check.var)] - ((unary (type (Box threadT varT)) varT extension-name) - analyse args)))) - -(def: box::write - Handler - (function (_ extension-name analyse args) - (do ////.Monad<Operation> - [[thread-id threadT] (typeA.with-env check.var) - [var-id varT] (typeA.with-env check.var)] - ((binary varT (type (Box threadT varT)) Any extension-name) - analyse args)))) - -(def: bundle::box - Bundle - (<| (bundle.prefix "box") - (|> bundle.empty - (bundle.install "new" box::new) - (bundle.install "read" box::read) - (bundle.install "write" box::write) - ))) - (def: #export bundle Bundle (<| (bundle.prefix "lux") @@ -253,6 +210,5 @@ (dict.merge bundle::int) (dict.merge bundle::frac) (dict.merge bundle::text) - (dict.merge bundle::box) (dict.merge bundle::io) ))) diff --git a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux index c46a5e82e..65184a7ea 100644 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux @@ -241,27 +241,6 @@ (bundle.install "exit" (unary _.exit/1)) (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) -## [[Box]] -(def: box::new - Unary - (|>> (list) _.vector/*)) - -(def: (box::read box) - Unary - (_.vector-ref/2 box (_.int +0))) - -(def: (box::write [valueO boxO]) - Binary - (runtime.box//write valueO boxO)) - -(def: bundle::box - Bundle - (<| (bundle.prefix "box") - (|> bundle.empty - (bundle.install "new" (unary box::new)) - (bundle.install "read" (unary box::read)) - (bundle.install "write" (binary box::write))))) - ## [Bundles] (def: #export bundle Bundle @@ -272,5 +251,4 @@ (dict.merge bundle::frac) (dict.merge bundle::text) (dict.merge bundle::io) - (dict.merge bundle::box) ))) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index b7aac24d7..2e7942355 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -4,29 +4,41 @@ [functor (#+ Functor)] [apply (#+ Apply)] [monad (#+ Monad do)]] + [data + [collection + ["." array]]] + [type (#+ :share) + abstract] + [compiler + ["." host]] [io (#+ IO)]]) (type: #export (Thread ! a) (-> ! a)) -(type: #export (Box t v) +(abstract: #export (Box t v) {#.doc "A mutable box holding a value."} - (#.Primitive "#Box" (#.Cons t (#.Cons v #.Nil)))) - -(def: #export (box init) - (All [a] (-> a (All [!] (Thread ! (Box ! a))))) - (function (_ !) - ("lux box new" init))) - -(def: #export (read box) - (All [! a] (-> (Box ! a) (Thread ! a))) - (function (_ !) - ("lux box read" box))) - -(def: #export (write value box) - (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) - (function (_ !) - ("lux box write" value box))) + + (Array v) + + (def: #export (box init) + (All [a] (-> a (All [!] (Thread ! (Box ! a))))) + (function (_ !) + (|> (array.new 1) + (array.write 0 init) + :abstraction))) + + (def: #export (read box) + (All [! a] (-> (Box ! a) (Thread ! a))) + (function (_ !) + (`` (for {(~~ (static host.jvm)) + ("jvm aaload" (:representation box) 0)})))) + + (def: #export (write value box) + (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) + (function (_ !) + (|> box :representation (array.write 0 value) :abstraction))) + ) (def: #export (run thread) (All [a] |