diff options
Diffstat (limited to 'new-luxc/source/luxc/lang')
| -rw-r--r-- | new-luxc/source/luxc/lang/extension/analysis/common.lux | 46 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux | 38 |
2 files changed, 83 insertions, 1 deletions
diff --git a/new-luxc/source/luxc/lang/extension/analysis/common.lux b/new-luxc/source/luxc/lang/extension/analysis/common.lux index 079001b26..1a1c8c650 100644 --- a/new-luxc/source/luxc/lang/extension/analysis/common.lux +++ b/new-luxc/source/luxc/lang/extension/analysis/common.lux @@ -392,6 +392,51 @@ (install "compare-and-swap" atom//compare-and-swap) ))) +(type: (Box ! a) + (#.Primitive "#Box" (#.Cons ! (#.Cons a #.Nil)))) + +(def: (box//new proc) + (-> Text ///.Analysis) + (function [analyse eval args] + (case args + (^ (list initC)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (All [!] (Box ! varT)))) + initA (&.with-type varT + (analyse initC))] + (wrap (la.procedure proc (list initA)))) + + _ + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) + +(def: (box//read proc) + (-> Text ///.Analysis) + (function [analyse eval args] + (do macro.Monad<Meta> + [[thread-id threadT] (&.with-type-env tc.var) + [var-id varT] (&.with-type-env tc.var)] + ((unary (type (Box threadT varT)) varT proc) + analyse eval args)))) + +(def: (box//write proc) + (-> Text ///.Analysis) + (function [analyse eval args] + (do macro.Monad<Meta> + [[thread-id threadT] (&.with-type-env tc.var) + [var-id varT] (&.with-type-env tc.var)] + ((binary varT (type (Box threadT varT)) Unit proc) + analyse eval args)))) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash<Text>) + (install "new" box//new) + (install "read" box//read) + (install "write" box//write) + ))) + (def: process-procs Bundle (<| (prefix "process") @@ -415,5 +460,6 @@ (dict.merge array-procs) (dict.merge math-procs) (dict.merge atom-procs) + (dict.merge box-procs) (dict.merge process-procs) (dict.merge io-procs)))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 336293dc4..84c42244e 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -141,6 +141,8 @@ ($i.label @end) ))) +(def: unitI $.Inst ($i.string hostL.unit)) + ## [Procedures] ## [[Lux]] (def: (lux//is [leftI rightI]) @@ -513,7 +515,7 @@ messageI ($i.CHECKCAST "java.lang.String") ($i.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) - ($i.string hostL.unit))) + unitI)) (def: (io//error messageI) Unary @@ -559,6 +561,31 @@ ($i.INVOKEVIRTUAL atom-class "compareAndSet" ($t.method (list $Object $Object) (#.Some $t.boolean) (list)) false) ($i.wrap #$.Boolean))) +## [[Box]] +(def: empty-boxI + $.Inst + (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) + +(def: check-boxI + $.Inst + ($i.CHECKCAST ($t.descriptor $Object-Array))) + +(def: (box//new initI) + Unary + (|>> empty-boxI + $i.DUP ($i.int 0) initI $i.AASTORE)) + +(def: (box//read boxI) + Unary + (|>> boxI check-boxI + ($i.int 0) $i.AALOAD)) + +(def: (box//write [valueI boxI]) + Binary + (|>> boxI check-boxI + ($i.int 0) valueI $i.AASTORE + unitI)) + ## [[Processes]] (def: (process//concurrency-level []) Nullary @@ -745,6 +772,14 @@ (install "read" (unary atom//read)) (install "compare-and-swap" (trinary atom//compare-and-swap))))) +(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: process-procs Bundle (<| (prefix "process") @@ -769,5 +804,6 @@ (dict.merge math-procs) (dict.merge io-procs) (dict.merge atom-procs) + (dict.merge box-procs) (dict.merge process-procs) ))) |