diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser')
-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 |
3 files changed, 622 insertions, 176 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) + ))) |