diff options
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure.lux | 16 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 357 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 425 | ||||
| -rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 9 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/procedure/common.lux | 202 |
5 files changed, 732 insertions, 277 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux index 06ea7c324..064a28e9b 100644 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ b/new-luxc/source/luxc/analyser/procedure.lux @@ -3,15 +3,21 @@ (lux (control [monad #+ do]) (data [text] text/format - (coll ["D" dict]) + (coll ["d" dict]) [maybe])) (luxc ["&" base] (lang ["la" analysis #+ Analysis])) - (. ["&&;" common])) + (. ["./;" common] + ["./;" host])) + +(def: procedures + ./common;Bundle + (|> ./common;procedures + (d;merge ./host;procedures))) (def: #export (analyse-procedure analyse proc-name proc-args) (-> &;Analyser Text (List Code) (Lux Analysis)) (default (&;fail (format "Unknown procedure: " (%t proc-name))) - (do maybe;Monad<Maybe> - [proc (D;get proc-name &&common;procedures)] - (wrap (proc analyse proc-args))))) + (do maybe;Monad<Maybe> + [proc (d;get proc-name procedures)] + (wrap (proc analyse proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index 0ba35a82e..c1ca36b17 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -4,9 +4,9 @@ (concurrency ["A" atom]) (data [text] text/format - (coll [list] + (coll [list "list/" Functor<List>] [array #+ Array] - ["D" dict])) + ["d" dict])) [macro #+ Monad<Lux>] (type ["TC" check]) [io]) @@ -15,24 +15,31 @@ (analyser ["&;" common]))) ## [Utils] -(type: Proc +(type: #export Proc (-> &;Analyser (List Code) (Lux Analysis))) -(type: Bundle - (D;Dict Text Proc)) +(type: #export Bundle + (d;Dict Text Proc)) -(def: (install name unnamed) +(def: #export (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (D;put name (unnamed name))) + (d;put name (unnamed name))) -(def: (wrong-amount-error proc expected actual) +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + d;entries + (list/map (function [[key val]] [(format prefix " " key) val])) + (d;from-list text;Hash<Text>))) + +(def: #export (wrong-amount-error proc expected actual) (-> Text Nat Nat Text) (format "Wrong number of arguments for " (%t proc) "\n" "Expected: " (|> expected nat-to-int %i) "\n" " Actual: " (|> actual nat-to-int %i))) -(def: (simple-proc proc input-types output-type) +(def: (simple proc input-types output-type) (-> Text (List Type) Type Proc) (let [num-expected (list;size input-types)] (function [analyse args] @@ -50,39 +57,35 @@ (wrap (#la;Procedure proc argsA))) (&;fail (wrong-amount-error proc num-expected num-actual))))))) -(def: (binary-operation subjectT paramT outputT proc) - (-> Type Type Type Text Proc) - (simple-proc proc (list subjectT paramT) outputT)) - -(def: (trinary-operation subjectT param0T param1T outputT proc) - (-> Type Type Type Type Text Proc) - (simple-proc proc (list subjectT param0T param1T) outputT)) +(def: #export (nullary valueT proc) + (-> Type Text Proc) + (simple proc (list) valueT)) -(def: (unary-operation inputT outputT proc) +(def: #export (unary inputT outputT proc) (-> Type Type Text Proc) - (simple-proc proc (list inputT) outputT)) + (simple proc (list inputT) outputT)) -(def: (special-value valueT proc) - (-> Type Text Proc) - (simple-proc proc (list) valueT)) +(def: #export (binary subjectT paramT outputT proc) + (-> Type Type Type Text Proc) + (simple proc (list subjectT paramT) outputT)) -(def: (converter fromT toT proc) - (-> Type Type Text Proc) - (simple-proc proc (list fromT) toT)) +(def: #export (trinary subjectT param0T param1T outputT proc) + (-> Type Type Type Type Text Proc) + (simple proc (list subjectT param0T param1T) outputT)) ## [Analysers] ## "lux is" represents reference/pointer equality. -(def: (analyse-lux-is proc) +(def: (lux-is proc) (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] - ((binary-operation varT varT Bool proc) + ((binary varT varT Bool proc) analyse args))))) ## "lux try" provides a simple way to interact with the host platform's ## error-handling facilities. -(def: (analyse-lux-try proc) +(def: (lux-try proc) (-> Text Proc) (function [analyse args] (&common;with-var @@ -104,169 +107,178 @@ (def: lux-procs Bundle - (|> (D;new text;Hash<Text>) - (install "lux is" analyse-lux-is) - (install "lux try" analyse-lux-try))) + (|> (d;new text;Hash<Text>) + (install "is" lux-is) + (install "try" lux-try))) (def: io-procs Bundle - (|> (D;new text;Hash<Text>) - (install "io log" (converter Text Unit)) - (install "io error" (converter Text Bottom)) - (install "io exit" (converter Nat Bottom)) - (install "io current-time" (special-value Int)))) + (<| (prefix "io") + (|> (d;new text;Hash<Text>) + (install "log" (unary Text Unit)) + (install "error" (unary Text Bottom)) + (install "exit" (unary Nat Bottom)) + (install "current-time" (nullary Int))))) (def: bit-procs Bundle - (|> (D;new text;Hash<Text>) - (install "bit count" (unary-operation Nat Nat)) - (install "bit and" (binary-operation Nat Nat Nat)) - (install "bit or" (binary-operation Nat Nat Nat)) - (install "bit xor" (binary-operation Nat Nat Nat)) - (install "bit shift-left" (binary-operation Nat Nat Nat)) - (install "bit unsigned-shift-right" (binary-operation Nat Nat Nat)) - (install "bit shift-right" (binary-operation Int Nat Int)) - )) + (<| (prefix "bit") + (|> (d;new text;Hash<Text>) + (install "count" (unary Nat Nat)) + (install "and" (binary Nat Nat Nat)) + (install "or" (binary Nat Nat Nat)) + (install "xor" (binary Nat Nat Nat)) + (install "shift-left" (binary Nat Nat Nat)) + (install "unsigned-shift-right" (binary Nat Nat Nat)) + (install "shift-right" (binary Int Nat Int)) + ))) (def: nat-procs Bundle - (|> (D;new text;Hash<Text>) - (install "nat +" (binary-operation Nat Nat Nat)) - (install "nat -" (binary-operation Nat Nat Nat)) - (install "nat *" (binary-operation Nat Nat Nat)) - (install "nat /" (binary-operation Nat Nat Nat)) - (install "nat %" (binary-operation Nat Nat Nat)) - (install "nat =" (binary-operation Nat Nat Bool)) - (install "nat <" (binary-operation Nat Nat Bool)) - (install "nat min" (special-value Nat)) - (install "nat max" (special-value Nat)) - (install "nat to-int" (converter Nat Int)) - (install "nat to-text" (converter Nat Text)))) + (<| (prefix "nat") + (|> (d;new text;Hash<Text>) + (install "+" (binary Nat Nat Nat)) + (install "-" (binary Nat Nat Nat)) + (install "*" (binary Nat Nat Nat)) + (install "/" (binary Nat Nat Nat)) + (install "%" (binary Nat Nat Nat)) + (install "=" (binary Nat Nat Bool)) + (install "<" (binary Nat Nat Bool)) + (install "min" (nullary Nat)) + (install "max" (nullary Nat)) + (install "to-int" (unary Nat Int)) + (install "to-text" (unary Nat Text))))) (def: int-procs Bundle - (|> (D;new text;Hash<Text>) - (install "int +" (binary-operation Int Int Int)) - (install "int -" (binary-operation Int Int Int)) - (install "int *" (binary-operation Int Int Int)) - (install "int /" (binary-operation Int Int Int)) - (install "int %" (binary-operation Int Int Int)) - (install "int =" (binary-operation Int Int Bool)) - (install "int <" (binary-operation Int Int Bool)) - (install "int min" (special-value Int)) - (install "int max" (special-value Int)) - (install "int to-nat" (converter Int Nat)) - (install "int to-frac" (converter Int Frac)))) + (<| (prefix "int") + (|> (d;new text;Hash<Text>) + (install "+" (binary Int Int Int)) + (install "-" (binary Int Int Int)) + (install "*" (binary Int Int Int)) + (install "/" (binary Int Int Int)) + (install "%" (binary Int Int Int)) + (install "=" (binary Int Int Bool)) + (install "<" (binary Int Int Bool)) + (install "min" (nullary Int)) + (install "max" (nullary Int)) + (install "to-nat" (unary Int Nat)) + (install "to-frac" (unary Int Frac))))) (def: deg-procs Bundle - (|> (D;new text;Hash<Text>) - (install "deg +" (binary-operation Deg Deg Deg)) - (install "deg -" (binary-operation Deg Deg Deg)) - (install "deg *" (binary-operation Deg Deg Deg)) - (install "deg /" (binary-operation Deg Deg Deg)) - (install "deg %" (binary-operation Deg Deg Deg)) - (install "deg =" (binary-operation Deg Deg Bool)) - (install "deg <" (binary-operation Deg Deg Bool)) - (install "deg scale" (binary-operation Deg Nat Deg)) - (install "deg reciprocal" (binary-operation Deg Nat Deg)) - (install "deg min" (special-value Deg)) - (install "deg max" (special-value Deg)) - (install "deg to-frac" (converter Deg Frac)))) + (<| (prefix "deg") + (|> (d;new text;Hash<Text>) + (install "+" (binary Deg Deg Deg)) + (install "-" (binary Deg Deg Deg)) + (install "*" (binary Deg Deg Deg)) + (install "/" (binary Deg Deg Deg)) + (install "%" (binary Deg Deg Deg)) + (install "=" (binary Deg Deg Bool)) + (install "<" (binary Deg Deg Bool)) + (install "scale" (binary Deg Nat Deg)) + (install "reciprocal" (binary Deg Nat Deg)) + (install "min" (nullary Deg)) + (install "max" (nullary Deg)) + (install "to-frac" (unary Deg Frac))))) (def: frac-procs Bundle - (|> (D;new text;Hash<Text>) - (install "frac +" (binary-operation Frac Frac Frac)) - (install "frac -" (binary-operation Frac Frac Frac)) - (install "frac *" (binary-operation Frac Frac Frac)) - (install "frac /" (binary-operation Frac Frac Frac)) - (install "frac %" (binary-operation Frac Frac Frac)) - (install "frac =" (binary-operation Frac Frac Bool)) - (install "frac <" (binary-operation Frac Frac Bool)) - (install "frac smallest" (special-value Frac)) - (install "frac min" (special-value Frac)) - (install "frac max" (special-value Frac)) - (install "frac not-a-number" (special-value Frac)) - (install "frac positive-infinity" (special-value Frac)) - (install "frac negative-infinity" (special-value Frac)) - (install "frac to-deg" (converter Frac Deg)) - (install "frac to-int" (converter Frac Int)) - (install "frac encode" (converter Frac Text)) - (install "frac decode" (converter Text (type (Maybe Frac)))))) + (<| (prefix "frac") + (|> (d;new text;Hash<Text>) + (install "+" (binary Frac Frac Frac)) + (install "-" (binary Frac Frac Frac)) + (install "*" (binary Frac Frac Frac)) + (install "/" (binary Frac Frac Frac)) + (install "%" (binary Frac Frac Frac)) + (install "=" (binary Frac Frac Bool)) + (install "<" (binary Frac Frac Bool)) + (install "smallest" (nullary Frac)) + (install "min" (nullary Frac)) + (install "max" (nullary Frac)) + (install "not-a-number" (nullary Frac)) + (install "positive-infinity" (nullary Frac)) + (install "negative-infinity" (nullary Frac)) + (install "to-deg" (unary Frac Deg)) + (install "to-int" (unary Frac Int)) + (install "encode" (unary Frac Text)) + (install "decode" (unary Text (type (Maybe Frac))))))) (def: text-procs Bundle - (|> (D;new text;Hash<Text>) - (install "text =" (binary-operation Text Text Bool)) - (install "text <" (binary-operation Text Text Bool)) - (install "text prepend" (binary-operation Text Text Text)) - (install "text index" (trinary-operation Text Text Nat (type (Maybe Nat)))) - (install "text size" (unary-operation Text Nat)) - (install "text hash" (unary-operation Text Nat)) - (install "text replace" (trinary-operation Text Text Text Text)) - (install "text char" (binary-operation Text Nat Nat)) - (install "text clip" (trinary-operation Text Nat Nat Text)) - )) + (<| (prefix "text") + (|> (d;new text;Hash<Text>) + (install "=" (binary Text Text Bool)) + (install "<" (binary Text Text Bool)) + (install "prepend" (binary Text Text Text)) + (install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (install "size" (unary Text Nat)) + (install "hash" (unary Text Nat)) + (install "replace" (trinary Text Text Text Text)) + (install "char" (binary Text Nat Nat)) + (install "clip" (trinary Text Nat Nat Text)) + ))) -(def: (analyse-array-get proc) +(def: (array-get proc) (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] - ((binary-operation Nat (type (Array varT)) varT proc) + ((binary Nat (type (Array varT)) varT proc) analyse args))))) -(def: (analyse-array-put proc) +(def: (array-put proc) (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] - ((trinary-operation Nat varT (type (Array varT)) (type (Array varT)) proc) + ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) analyse args))))) -(def: (analyse-array-remove proc) +(def: (array-remove proc) (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] - ((binary-operation Nat (type (Array varT)) (type (Array varT)) proc) + ((binary Nat (type (Array varT)) (type (Array varT)) proc) analyse args))))) (def: array-procs Bundle - (|> (D;new text;Hash<Text>) - (install "array new" (unary-operation Nat Array)) - (install "array get" analyse-array-get) - (install "array put" analyse-array-put) - (install "array remove" analyse-array-remove) - (install "array size" (unary-operation (type (Ex [a] (Array a))) Nat)) - )) + (<| (prefix "array") + (|> (d;new text;Hash<Text>) + (install "new" (unary Nat Array)) + (install "get" array-get) + (install "put" array-put) + (install "remove" array-remove) + (install "size" (unary (type (Ex [a] (Array a))) Nat)) + ))) (def: math-procs Bundle - (|> (D;new text;Hash<Text>) - (install "math cos" (unary-operation Frac Frac)) - (install "math sin" (unary-operation Frac Frac)) - (install "math tan" (unary-operation Frac Frac)) - (install "math acos" (unary-operation Frac Frac)) - (install "math asin" (unary-operation Frac Frac)) - (install "math atan" (unary-operation Frac Frac)) - (install "math cosh" (unary-operation Frac Frac)) - (install "math sinh" (unary-operation Frac Frac)) - (install "math tanh" (unary-operation Frac Frac)) - (install "math exp" (unary-operation Frac Frac)) - (install "math log" (unary-operation Frac Frac)) - (install "math root2" (unary-operation Frac Frac)) - (install "math root3" (unary-operation Frac Frac)) - (install "math ceil" (unary-operation Frac Frac)) - (install "math floor" (unary-operation Frac Frac)) - (install "math round" (unary-operation Frac Frac)) - (install "math atan2" (binary-operation Frac Frac Frac)) - (install "math pow" (binary-operation Frac Frac Frac)) - )) + (<| (prefix "math") + (|> (d;new text;Hash<Text>) + (install "cos" (unary Frac Frac)) + (install "sin" (unary Frac Frac)) + (install "tan" (unary Frac Frac)) + (install "acos" (unary Frac Frac)) + (install "asin" (unary Frac Frac)) + (install "atan" (unary Frac Frac)) + (install "cosh" (unary Frac Frac)) + (install "sinh" (unary Frac Frac)) + (install "tanh" (unary Frac Frac)) + (install "exp" (unary Frac Frac)) + (install "log" (unary Frac Frac)) + (install "root2" (unary Frac Frac)) + (install "root3" (unary Frac Frac)) + (install "ceil" (unary Frac Frac)) + (install "floor" (unary Frac Frac)) + (install "round" (unary Frac Frac)) + (install "atan2" (binary Frac Frac Frac)) + (install "pow" (binary Frac Frac Frac)) + ))) -(def: (analyse-atom-new proc) +(def: (atom-new proc) (-> Text Proc) (function [analyse args] (&common;with-var @@ -286,50 +298,53 @@ _ (&;fail (wrong-amount-error proc +1 (list;size args)))))))) -(def: (analyse-atom-read proc) +(def: (atom-read proc) (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] - ((unary-operation (type (A;Atom varT)) varT proc) + ((unary (type (A;Atom varT)) varT proc) analyse args))))) -(def: (analyse-atom-compare-and-swap proc) +(def: (atom-compare-and-swap proc) (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] - ((trinary-operation varT varT (type (A;Atom varT)) Bool proc) + ((trinary varT varT (type (A;Atom varT)) Bool proc) analyse args))))) (def: atom-procs Bundle - (|> (D;new text;Hash<Text>) - (install "atom new" analyse-atom-new) - (install "atom read" analyse-atom-read) - (install "atom compare-and-swap" analyse-atom-compare-and-swap) - )) + (<| (prefix "atom") + (|> (d;new text;Hash<Text>) + (install "new" atom-new) + (install "read" atom-read) + (install "compare-and-swap" atom-compare-and-swap) + ))) (def: process-procs Bundle - (|> (D;new text;Hash<Text>) - (install "process concurrency-level" (special-value Nat)) - (install "process future" (unary-operation (type (io;IO Top)) Unit)) - (install "process schedule" (binary-operation Nat (type (io;IO Top)) Unit)) - )) + (<| (prefix "process") + (|> (d;new text;Hash<Text>) + (install "concurrency-level" (nullary Nat)) + (install "future" (unary (type (io;IO Top)) Unit)) + (install "schedule" (binary Nat (type (io;IO Top)) Unit)) + ))) (def: #export procedures Bundle - (|> (D;new text;Hash<Text>) - (D;merge lux-procs) - (D;merge bit-procs) - (D;merge nat-procs) - (D;merge int-procs) - (D;merge deg-procs) - (D;merge frac-procs) - (D;merge text-procs) - (D;merge array-procs) - (D;merge math-procs) - (D;merge atom-procs) - (D;merge process-procs) - (D;merge io-procs))) + (<| (prefix "lux") + (|> (d;new text;Hash<Text>) + (d;merge lux-procs) + (d;merge bit-procs) + (d;merge nat-procs) + (d;merge int-procs) + (d;merge deg-procs) + (d;merge frac-procs) + (d;merge text-procs) + (d;merge array-procs) + (d;merge math-procs) + (d;merge atom-procs) + (d;merge process-procs) + (d;merge io-procs)))) diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux new file mode 100644 index 000000000..c8dc5a38a --- /dev/null +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -0,0 +1,425 @@ +(;module: + [lux #- char] + (lux (control [monad #+ do] + ["p" parser]) + (concurrency ["A" atom]) + (data ["R" result] + [text] + (text format + ["l" lexer]) + (coll [list "list/" Fold<List>] + [array #+ Array] + ["d" dict])) + [macro #+ Monad<Lux>] + (type ["TC" check]) + [host]) + (luxc ["&" base] + ["&;" host] + (lang ["la" analysis #+ Analysis]) + (analyser ["&;" common])) + ["@" ../common] + ) + +(def: Boolean Type (host java.lang.Boolean)) +(def: Byte Type (host java.lang.Byte)) +(def: Short Type (host java.lang.Short)) +(def: Integer Type (host java.lang.Integer)) +(def: Long Type (host java.lang.Long)) +(def: Float Type (host java.lang.Float)) +(def: Double Type (host java.lang.Double)) +(def: Character Type (host java.lang.Character)) +(def: String Type (host java.lang.String)) + +(def: boolean Type (host boolean)) +(def: byte Type (host byte)) +(def: short Type (host short)) +(def: int Type (host int)) +(def: long Type (host long)) +(def: float Type (host float)) +(def: double Type (host double)) +(def: char Type (host char)) + +(def: converter-procs + @;Bundle + (<| (@;prefix "convert") + (|> (d;new text;Hash<Text>) + (@;install "double-to-float" (@;unary Double Float)) + (@;install "double-to-int" (@;unary Double Integer)) + (@;install "double-to-long" (@;unary Double Long)) + (@;install "float-to-double" (@;unary Float Double)) + (@;install "float-to-int" (@;unary Float Integer)) + (@;install "float-to-long" (@;unary Float Long)) + (@;install "int-to-byte" (@;unary Integer Byte)) + (@;install "int-to-char" (@;unary Integer Character)) + (@;install "int-to-double" (@;unary Integer Double)) + (@;install "int-to-float" (@;unary Integer Float)) + (@;install "int-to-long" (@;unary Integer Long)) + (@;install "int-to-short" (@;unary Integer Short)) + (@;install "long-to-double" (@;unary Long Double)) + (@;install "long-to-float" (@;unary Long Float)) + (@;install "long-to-int" (@;unary Long Integer)) + (@;install "long-to-short" (@;unary Long Short)) + (@;install "long-to-byte" (@;unary Long Byte)) + (@;install "char-to-byte" (@;unary Character Byte)) + (@;install "char-to-short" (@;unary Character Short)) + (@;install "char-to-int" (@;unary Character Integer)) + (@;install "char-to-long" (@;unary Character Long)) + (@;install "byte-to-long" (@;unary Byte Long)) + (@;install "short-to-long" (@;unary Short Long)) + ))) + +(do-template [<name> <prefix> <type>] + [(def: <name> + @;Bundle + (<| (@;prefix <prefix>) + (|> (d;new text;Hash<Text>) + (@;install "add" (@;binary <type> <type> <type>)) + (@;install "sub" (@;binary <type> <type> <type>)) + (@;install "mul" (@;binary <type> <type> <type>)) + (@;install "div" (@;binary <type> <type> <type>)) + (@;install "rem" (@;binary <type> <type> <type>)) + (@;install "eq" (@;binary <type> <type> Boolean)) + (@;install "lt" (@;binary <type> <type> Boolean)) + (@;install "gt" (@;binary <type> <type> Boolean)) + (@;install "and" (@;binary <type> <type> <type>)) + (@;install "or" (@;binary <type> <type> <type>)) + (@;install "xor" (@;binary <type> <type> <type>)) + (@;install "shl" (@;binary <type> Integer <type>)) + (@;install "shr" (@;binary <type> Integer <type>)) + (@;install "ushr" (@;binary <type> Integer <type>)) + )))] + + [int-procs "int" Integer] + [long-procs "long" Long] + ) + +(do-template [<name> <prefix> <type>] + [(def: <name> + @;Bundle + (<| (@;prefix <prefix>) + (|> (d;new text;Hash<Text>) + (@;install "add" (@;binary <type> <type> <type>)) + (@;install "sub" (@;binary <type> <type> <type>)) + (@;install "mul" (@;binary <type> <type> <type>)) + (@;install "div" (@;binary <type> <type> <type>)) + (@;install "rem" (@;binary <type> <type> <type>)) + (@;install "eq" (@;binary <type> <type> Boolean)) + (@;install "lt" (@;binary <type> <type> Boolean)) + (@;install "gt" (@;binary <type> <type> Boolean)) + )))] + + [float-procs "float" Float] + [double-procs "double" Double] + ) + +(def: char-procs + @;Bundle + (<| (@;prefix "char") + (|> (d;new text;Hash<Text>) + (@;install "ceq" (@;binary Character Character Boolean)) + (@;install "clt" (@;binary Character Character Boolean)) + (@;install "cgt" (@;binary Character Character Boolean)) + ))) + +(def: primitive-boxes + (d;Dict Text Text) + (|> (list ["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + (d;from-list text;Hash<Text>))) + +(def: array-type + (l;Lexer [Type Nat Text]) + (do p;Monad<Parser> + [subs (p;some (l;this "[")) + #let [level (list;size subs)] + class (l;many l;any)] + (wrap [(list/fold (function [_ inner] + (type (Array inner))) + (#;Host (|> (d;get class primitive-boxes) + (default class)) + (list)) + (list;n.range +1 level)) + level + class]))) + +(def: (array-length proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC)) + (do Monad<Lux> + [arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT Nat))] + (wrap (#la;Procedure proc (list arrayA)))) + + _ + (&;fail (@;wrong-amount-error proc +1 (list;size args)))))))) + +(def: (array-new proc) + (-> Text @;Proc) + (function [analyse args] + (case args + (^ (list classC lengthC)) + (case classC + [_ (#;Text classC)] + (do Monad<Lux> + [lengthA (&;with-expected-type Nat + (analyse lengthC)) + arrayT (case (l;run classC array-type) + (#R;Success [innerT level elem-class]) + (wrap (type (Array innerT))) + + (#R;Error error) + (&;fail error)) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT arrayT))] + (wrap (#la;Procedure proc (list (#la;Text classC) lengthA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-amount-error proc +2 (list;size args)))))) + +(def: (array-load proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC idxC)) + (do Monad<Lux> + [arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + elemT (&;within-type-env + (TC;read-var var-id)) + elem-class (case elemT + (#;Host name _) + (wrap name) + + _ + (&;fail (format "Invalid type for array element: " (%type elemT)))) + idxA (&;with-expected-type Nat + (analyse idxC)) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT elemT))] + (wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA)))) + + _ + (&;fail (@;wrong-amount-error proc +2 (list;size args)))))))) + +(def: (array-store proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC idxC valueC)) + (do Monad<Lux> + [arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + elemT (&;within-type-env + (TC;read-var var-id)) + elem-class (case elemT + (#;Host name _) + (wrap name) + + _ + (&;fail (format "Invalid type for array element: " (%type elemT)))) + idxA (&;with-expected-type Nat + (analyse idxC)) + valueA (&;with-expected-type elemT + (analyse valueC)) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT (type (Array elemT))))] + (wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA valueA)))) + + _ + (&;fail (@;wrong-amount-error proc +3 (list;size args)))))))) + +(def: array-procs + @;Bundle + (<| (@;prefix "array") + (|> (d;new text;Hash<Text>) + (@;install "length" array-length) + (@;install "new" array-new) + (@;install "load" array-load) + (@;install "store" array-store) + ))) + +(def: (check-object objectT) + (-> Type (Lux Text)) + (case objectT + (#;Host name _) + (if (d;contains? name primitive-boxes) + (&;fail (format "Primitives are not objects: " name)) + (:: Monad<Lux> wrap name)) + + _ + (&;fail (format "Non-object type: " (%type objectT))))) + +(def: (object-null proc) + (-> Text @;Proc) + (function [analyse args] + (case args + (^ (list)) + (do Monad<Lux> + [expectedT macro;expected-type + _ (check-object expectedT)] + (wrap (#la;Procedure proc (list)))) + + _ + (&;fail (@;wrong-amount-error proc +0 (list;size args)))))) + +(def: (object-null? proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list objectC)) + (do Monad<Lux> + [objectA (&;with-expected-type (type varT) + (analyse objectC)) + objectT (&;within-type-env + (TC;read-var var-id)) + _ (check-object objectT) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT Bool))] + (wrap (#la;Procedure proc (list objectA)))) + + _ + (&;fail (@;wrong-amount-error proc +1 (list;size args)))))))) + +(def: (object-synchronized proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list monitorC exprC)) + (do Monad<Lux> + [monitorA (&;with-expected-type (type varT) + (analyse monitorC)) + monitorT (&;within-type-env + (TC;read-var var-id)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#la;Procedure proc (list monitorA exprA)))) + + _ + (&;fail (@;wrong-amount-error proc +2 (list;size args)))))))) + +(host;import java.lang.Object) + +(host;import java.lang.ClassLoader) + +(host;import (java.lang.Class c) + (#static forName [String boolean ClassLoader] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean)) + +(def: (load-class name) + (-> Text (Lux (Class Object))) + (do Monad<Lux> + [class-loader &host;class-loader] + (case (Class.forName [name false class-loader]) + (#R;Success [class]) + (wrap class) + + (#R;Error error) + (&;fail (format "Unknown class: " name))))) + +(def: (sub-class? super sub) + (-> Text Text (Lux Bool)) + (do Monad<Lux> + [super (load-class super) + sub (load-class sub)] + (wrap (Class.isAssignableFrom [sub] super)))) + +(def: (object-throw proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list exceptionC)) + (do Monad<Lux> + [exceptionA (&;with-expected-type (type varT) + (analyse exceptionC)) + exceptionT (&;within-type-env + (TC;read-var var-id)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Lux Unit) + (if ? + (wrap []) + (&;fail (format "Must throw a sub-class of java.lang.Throwable: " exception-class)))) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT Bottom))] + (wrap (#la;Procedure proc (list exceptionA)))) + + _ + (&;fail (@;wrong-amount-error proc +1 (list;size args)))))))) + +(def: (object-class proc) + (-> Text @;Proc) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list classC)) + (case classC + [_ (#;Text class)] + (do Monad<Lux> + [_ (load-class class) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT (#;Host "java.lang.Class" (list (#;Host class (list))))))] + (wrap (#la;Procedure proc (list (#la;Text class))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-amount-error proc +1 (list;size args)))))))) + +(def: object-procs + @;Bundle + (<| (@;prefix "object") + (|> (d;new text;Hash<Text>) + (@;install "null" object-null) + (@;install "null?" object-null?) + (@;install "synchronized" object-synchronized) + (@;install "throw" object-throw) + (@;install "class" object-class) + ))) + +(def: #export procedures + @;Bundle + (<| (@;prefix "jvm") + (|> (d;new text;Hash<Text>) + (d;merge converter-procs) + (d;merge int-procs) + (d;merge long-procs) + (d;merge float-procs) + (d;merge double-procs) + (d;merge char-procs) + (d;merge array-procs) + (d;merge object-procs) + ))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index 75cfbec0c..55c899143 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -85,3 +85,12 @@ {#&&common;loader (memory-class-loader store) #&&common;store store #&&common;function-class #;None}))) + +(def: #export class-loader + (Lux ClassLoader) + (function [compiler] + (#R;Success [compiler + (|> compiler + (get@ #;host) + (:! &&common;Host) + (get@ #&&common;loader))]))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux index 3947a738e..5e834746a 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/common.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/common.lux @@ -60,19 +60,19 @@ paramC (|> r;nat (:: @ map code;nat))] ($_ seq (test "Can count the number of 1 bits in a bit pattern." - (check-success+ "bit count" (list subjectC) Nat)) + (check-success+ "lux bit count" (list subjectC) Nat)) (test "Can perform bit 'and'." - (check-success+ "bit and" (list subjectC paramC) Nat)) + (check-success+ "lux bit and" (list subjectC paramC) Nat)) (test "Can perform bit 'or'." - (check-success+ "bit or" (list subjectC paramC) Nat)) + (check-success+ "lux bit or" (list subjectC paramC) Nat)) (test "Can perform bit 'xor'." - (check-success+ "bit xor" (list subjectC paramC) Nat)) + (check-success+ "lux bit xor" (list subjectC paramC) Nat)) (test "Can shift bit pattern to the left." - (check-success+ "bit shift-left" (list subjectC paramC) Nat)) + (check-success+ "lux bit shift-left" (list subjectC paramC) Nat)) (test "Can shift bit pattern to the right." - (check-success+ "bit unsigned-shift-right" (list subjectC paramC) Nat)) + (check-success+ "lux bit unsigned-shift-right" (list subjectC paramC) Nat)) (test "Can shift signed bit pattern to the right." - (check-success+ "bit shift-right" (list signedC paramC) Int)) + (check-success+ "lux bit shift-right" (list signedC paramC) Int)) )) (context: "Nat procedures" @@ -80,27 +80,27 @@ paramC (|> r;nat (:: @ map code;nat))] ($_ seq (test "Can add natural numbers." - (check-success+ "nat +" (list subjectC paramC) Nat)) + (check-success+ "lux nat +" (list subjectC paramC) Nat)) (test "Can subtract natural numbers." - (check-success+ "nat -" (list subjectC paramC) Nat)) + (check-success+ "lux nat -" (list subjectC paramC) Nat)) (test "Can multiply natural numbers." - (check-success+ "nat *" (list subjectC paramC) Nat)) + (check-success+ "lux nat *" (list subjectC paramC) Nat)) (test "Can divide natural numbers." - (check-success+ "nat /" (list subjectC paramC) Nat)) + (check-success+ "lux nat /" (list subjectC paramC) Nat)) (test "Can calculate remainder of natural numbers." - (check-success+ "nat %" (list subjectC paramC) Nat)) + (check-success+ "lux nat %" (list subjectC paramC) Nat)) (test "Can test equality of natural numbers." - (check-success+ "nat =" (list subjectC paramC) Bool)) + (check-success+ "lux nat =" (list subjectC paramC) Bool)) (test "Can compare natural numbers." - (check-success+ "nat <" (list subjectC paramC) Bool)) + (check-success+ "lux nat <" (list subjectC paramC) Bool)) (test "Can obtain minimum natural number." - (check-success+ "nat min" (list) Nat)) + (check-success+ "lux nat min" (list) Nat)) (test "Can obtain maximum natural number." - (check-success+ "nat max" (list) Nat)) + (check-success+ "lux nat max" (list) Nat)) (test "Can convert natural number to integer." - (check-success+ "nat to-int" (list subjectC) Int)) + (check-success+ "lux nat to-int" (list subjectC) Int)) (test "Can convert natural number to text." - (check-success+ "nat to-text" (list subjectC) Text)) + (check-success+ "lux nat to-text" (list subjectC) Text)) )) (context: "Int procedures" @@ -108,27 +108,27 @@ paramC (|> r;int (:: @ map code;int))] ($_ seq (test "Can add integers." - (check-success+ "int +" (list subjectC paramC) Int)) + (check-success+ "lux int +" (list subjectC paramC) Int)) (test "Can subtract integers." - (check-success+ "int -" (list subjectC paramC) Int)) + (check-success+ "lux int -" (list subjectC paramC) Int)) (test "Can multiply integers." - (check-success+ "int *" (list subjectC paramC) Int)) + (check-success+ "lux int *" (list subjectC paramC) Int)) (test "Can divide integers." - (check-success+ "int /" (list subjectC paramC) Int)) + (check-success+ "lux int /" (list subjectC paramC) Int)) (test "Can calculate remainder of integers." - (check-success+ "int %" (list subjectC paramC) Int)) + (check-success+ "lux int %" (list subjectC paramC) Int)) (test "Can test equality of integers." - (check-success+ "int =" (list subjectC paramC) Bool)) + (check-success+ "lux int =" (list subjectC paramC) Bool)) (test "Can compare integers." - (check-success+ "int <" (list subjectC paramC) Bool)) + (check-success+ "lux int <" (list subjectC paramC) Bool)) (test "Can obtain minimum integer." - (check-success+ "int min" (list) Int)) + (check-success+ "lux int min" (list) Int)) (test "Can obtain maximum integer." - (check-success+ "int max" (list) Int)) + (check-success+ "lux int max" (list) Int)) (test "Can convert integer to natural number." - (check-success+ "int to-nat" (list subjectC) Nat)) + (check-success+ "lux int to-nat" (list subjectC) Nat)) (test "Can convert integer to frac number." - (check-success+ "int to-frac" (list subjectC) Frac)) + (check-success+ "lux int to-frac" (list subjectC) Frac)) )) (context: "Deg procedures" @@ -137,29 +137,29 @@ natC (|> r;nat (:: @ map code;nat))] ($_ seq (test "Can add degrees." - (check-success+ "deg +" (list subjectC paramC) Deg)) + (check-success+ "lux deg +" (list subjectC paramC) Deg)) (test "Can subtract degrees." - (check-success+ "deg -" (list subjectC paramC) Deg)) + (check-success+ "lux deg -" (list subjectC paramC) Deg)) (test "Can multiply degrees." - (check-success+ "deg *" (list subjectC paramC) Deg)) + (check-success+ "lux deg *" (list subjectC paramC) Deg)) (test "Can divide degrees." - (check-success+ "deg /" (list subjectC paramC) Deg)) + (check-success+ "lux deg /" (list subjectC paramC) Deg)) (test "Can calculate remainder of degrees." - (check-success+ "deg %" (list subjectC paramC) Deg)) + (check-success+ "lux deg %" (list subjectC paramC) Deg)) (test "Can test equality of degrees." - (check-success+ "deg =" (list subjectC paramC) Bool)) + (check-success+ "lux deg =" (list subjectC paramC) Bool)) (test "Can compare degrees." - (check-success+ "deg <" (list subjectC paramC) Bool)) + (check-success+ "lux deg <" (list subjectC paramC) Bool)) (test "Can obtain minimum degree." - (check-success+ "deg min" (list) Deg)) + (check-success+ "lux deg min" (list) Deg)) (test "Can obtain maximum degree." - (check-success+ "deg max" (list) Deg)) + (check-success+ "lux deg max" (list) Deg)) (test "Can convert degree to frac number." - (check-success+ "deg to-frac" (list subjectC) Frac)) + (check-success+ "lux deg to-frac" (list subjectC) Frac)) (test "Can scale degree." - (check-success+ "deg scale" (list subjectC natC) Deg)) + (check-success+ "lux deg scale" (list subjectC natC) Deg)) (test "Can calculate the reciprocal of a natural number." - (check-success+ "deg reciprocal" (list natC) Deg)) + (check-success+ "lux deg reciprocal" (list natC) Deg)) )) (context: "Frac procedures" @@ -168,39 +168,39 @@ encodedC (|> (r;text +5) (:: @ map code;text))] ($_ seq (test "Can add frac numbers." - (check-success+ "frac +" (list subjectC paramC) Frac)) + (check-success+ "lux frac +" (list subjectC paramC) Frac)) (test "Can subtract frac numbers." - (check-success+ "frac -" (list subjectC paramC) Frac)) + (check-success+ "lux frac -" (list subjectC paramC) Frac)) (test "Can multiply frac numbers." - (check-success+ "frac *" (list subjectC paramC) Frac)) + (check-success+ "lux frac *" (list subjectC paramC) Frac)) (test "Can divide frac numbers." - (check-success+ "frac /" (list subjectC paramC) Frac)) + (check-success+ "lux frac /" (list subjectC paramC) Frac)) (test "Can calculate remainder of frac numbers." - (check-success+ "frac %" (list subjectC paramC) Frac)) + (check-success+ "lux frac %" (list subjectC paramC) Frac)) (test "Can test equality of frac numbers." - (check-success+ "frac =" (list subjectC paramC) Bool)) + (check-success+ "lux frac =" (list subjectC paramC) Bool)) (test "Can compare frac numbers." - (check-success+ "frac <" (list subjectC paramC) Bool)) + (check-success+ "lux frac <" (list subjectC paramC) Bool)) (test "Can obtain minimum frac number." - (check-success+ "frac min" (list) Frac)) + (check-success+ "lux frac min" (list) Frac)) (test "Can obtain maximum frac number." - (check-success+ "frac max" (list) Frac)) + (check-success+ "lux frac max" (list) Frac)) (test "Can obtain smallest frac number." - (check-success+ "frac smallest" (list) Frac)) + (check-success+ "lux frac smallest" (list) Frac)) (test "Can obtain not-a-number." - (check-success+ "frac not-a-number" (list) Frac)) + (check-success+ "lux frac not-a-number" (list) Frac)) (test "Can obtain positive infinity." - (check-success+ "frac positive-infinity" (list) Frac)) + (check-success+ "lux frac positive-infinity" (list) Frac)) (test "Can obtain negative infinity." - (check-success+ "frac negative-infinity" (list) Frac)) + (check-success+ "lux frac negative-infinity" (list) Frac)) (test "Can convert frac number to integer." - (check-success+ "frac to-int" (list subjectC) Int)) + (check-success+ "lux frac to-int" (list subjectC) Int)) (test "Can convert frac number to degree." - (check-success+ "frac to-deg" (list subjectC) Deg)) + (check-success+ "lux frac to-deg" (list subjectC) Deg)) (test "Can convert frac number to text." - (check-success+ "frac encode" (list subjectC) Text)) + (check-success+ "lux frac encode" (list subjectC) Text)) (test "Can convert text to frac number." - (check-success+ "frac encode" (list encodedC) (type (Maybe Frac)))) + (check-success+ "lux frac encode" (list encodedC) (type (Maybe Frac)))) )) (context: "Text procedures" @@ -211,25 +211,25 @@ toC (|> r;nat (:: @ map code;nat))] ($_ seq (test "Can test text equality." - (check-success+ "text =" (list subjectC paramC) Bool)) + (check-success+ "lux text =" (list subjectC paramC) Bool)) (test "Compare texts in lexicographical order." - (check-success+ "text <" (list subjectC paramC) Bool)) + (check-success+ "lux text <" (list subjectC paramC) Bool)) (test "Can prepend one text to another." - (check-success+ "text prepend" (list subjectC paramC) Text)) + (check-success+ "lux text prepend" (list subjectC paramC) Text)) (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) (test "Can query the size/length of a text." - (check-success+ "text size" (list subjectC) Nat)) + (check-success+ "lux text size" (list subjectC) Nat)) (test "Can calculate a hash code for text." - (check-success+ "text hash" (list subjectC) Nat)) + (check-success+ "lux text hash" (list subjectC) Nat)) (test "Can replace a text inside of a larger one (once)." - (check-success+ "text replace-once" (list subjectC paramC replacementC) Text)) + (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) (test "Can replace a text inside of a larger one (all times)." - (check-success+ "text replace-all" (list subjectC paramC replacementC) Text)) + (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) (test "Can obtain the character code of a text at a given index." - (check-success+ "text char" (list subjectC fromC) Nat)) + (check-success+ "lux text char" (list subjectC fromC) Nat)) (test "Can clip a piece of text between 2 indices." - (check-success+ "text clip" (list subjectC fromC toC) Text)) + (check-success+ "lux text clip" (list subjectC fromC toC) Text)) )) (context: "Array procedures" @@ -240,12 +240,12 @@ #let [arrayT (type (array;Array elemT))]] ($_ seq (test "Can create arrays." - (check-success+ "array new" (list sizeC) arrayT)) + (check-success+ "lux array new" (list sizeC) arrayT)) (test "Can get a value inside an array." (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] (&;with-expected-type elemT - (@;analyse-procedure analyse "array get" + (@;analyse-procedure analyse "lux array get" (list idxC (code;symbol ["" var-name])))))) (macro;run (init-compiler [])) @@ -258,7 +258,7 @@ (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] (&;with-expected-type arrayT - (@;analyse-procedure analyse "array put" + (@;analyse-procedure analyse "lux array put" (list idxC elemC (code;symbol ["" var-name])))))) @@ -272,7 +272,7 @@ (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] (&;with-expected-type arrayT - (@;analyse-procedure analyse "array remove" + (@;analyse-procedure analyse "lux array remove" (list idxC (code;symbol ["" var-name])))))) (macro;run (init-compiler [])) @@ -285,7 +285,7 @@ (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] (&;with-expected-type Nat - (@;analyse-procedure analyse "array size" + (@;analyse-procedure analyse "lux array size" (list (code;symbol ["" var-name])))))) (macro;run (init-compiler [])) (case> (#R;Success _) @@ -302,28 +302,28 @@ [(test (format "Can calculate " <desc> ".") (check-success+ <proc> (list subjectC) Frac))] - ["math cos" "cosine"] - ["math sin" "sine"] - ["math tan" "tangent"] - ["math acos" "inverse/arc cosine"] - ["math asin" "inverse/arc sine"] - ["math atan" "inverse/arc tangent"] - ["math cosh" "hyperbolic cosine"] - ["math sinh" "hyperbolic sine"] - ["math tanh" "hyperbolic tangent"] - ["math exp" "exponentiation"] - ["math log" "logarithm"] - ["math root2" "square root"] - ["math root3" "cubic root"] - ["math ceil" "ceiling"] - ["math floor" "floor"] - ["math round" "rounding"]) + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math root2" "square root"] + ["lux math root3" "cubic root"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"]) <binary> (do-template [<proc> <desc>] [(test (format "Can calculate " <desc> ".") (check-success+ <proc> (list subjectC paramC) Frac))] - ["math atan2" "inverse/arc tangent (with 2 arguments)"] - ["math pow" "power"])] + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"])] ($_ seq <unary> <binary>))) @@ -336,12 +336,12 @@ #let [atomT (type (atom;Atom elemT))]] ($_ seq (test "Can create atomic reference." - (check-success+ "atom new" (list elemC) atomT)) + (check-success+ "lux atom new" (list elemC) atomT)) (test "Can read the value of an atomic reference." (|> (&scope;with-scope "" (&scope;with-local [var-name atomT] (&;with-expected-type elemT - (@;analyse-procedure analyse "atom read" + (@;analyse-procedure analyse "lux atom read" (list (code;symbol ["" var-name])))))) (macro;run (init-compiler [])) (case> (#R;Success _) @@ -353,7 +353,7 @@ (|> (&scope;with-scope "" (&scope;with-local [var-name atomT] (&;with-expected-type Bool - (@;analyse-procedure analyse "atom compare-and-swap" + (@;analyse-procedure analyse "lux atom compare-and-swap" (list elemC elemC (code;symbol ["" var-name])))))) @@ -370,13 +370,13 @@ timeC (|> r;nat (:: @ map code;nat))] ($_ seq (test "Can query the level of concurrency." - (check-success+ "process concurrency-level" (list) Nat)) + (check-success+ "lux process concurrency-level" (list) Nat)) (test "Can run an IO computation concurrently." - (check-success+ "process future" + (check-success+ "lux process future" (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) Unit)) (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "process schedule" + (check-success+ "lux process schedule" (list timeC (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) Unit)) @@ -387,11 +387,11 @@ exitC (|> r;nat (:: @ map code;nat))] ($_ seq (test "Can log messages to standard output." - (check-success+ "io log" (list logC) Unit)) + (check-success+ "lux io log" (list logC) Unit)) (test "Can log messages to standard output." - (check-success+ "io error" (list logC) Bottom)) + (check-success+ "lux io error" (list logC) Bottom)) (test "Can log messages to standard output." - (check-success+ "io exit" (list exitC) Bottom)) + (check-success+ "lux io exit" (list exitC) Bottom)) (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "io current-time" (list) Int)) + (check-success+ "lux io current-time" (list) Int)) )) |