diff options
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 222 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux | 353 | ||||
| -rw-r--r-- | new-luxc/test/tests.lux | 3 |
3 files changed, 473 insertions, 105 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index c8dc5a38a..c75d6efd4 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -11,6 +11,7 @@ [array #+ Array] ["d" dict])) [macro #+ Monad<Lux>] + [type] (type ["TC" check]) [host]) (luxc ["&" base] @@ -20,26 +21,32 @@ ["@" ../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 +(do-template [<name> <class>] + [(def: #export <name> Type (#;Host <class> (list)))] + + ## Boxes + [Boolean "java.lang.Boolean"] + [Byte "java.lang.Byte"] + [Short "java.lang.Short"] + [Integer "java.lang.Integer"] + [Long "java.lang.Long"] + [Float "java.lang.Float"] + [Double "java.lang.Double"] + [Character "java.lang.Character"] + [String "java.lang.String"] + + ## Primitives + [boolean "boolean"] + [byte "byte"] + [short "short"] + [int "int"] + [long "long"] + [float "float"] + [double "double"] + [char "char"] + ) + +(def: conversion-procs @;Bundle (<| (@;prefix "convert") (|> (d;new text;Hash<Text>) @@ -73,14 +80,14 @@ @;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 "+" (@;binary <type> <type> <type>)) + (@;install "-" (@;binary <type> <type> <type>)) + (@;install "*" (@;binary <type> <type> <type>)) + (@;install "/" (@;binary <type> <type> <type>)) + (@;install "%" (@;binary <type> <type> <type>)) + (@;install "=" (@;binary <type> <type> Boolean)) + (@;install "<" (@;binary <type> <type> Boolean)) + (@;install ">" (@;binary <type> <type> Boolean)) (@;install "and" (@;binary <type> <type> <type>)) (@;install "or" (@;binary <type> <type> <type>)) (@;install "xor" (@;binary <type> <type> <type>)) @@ -98,14 +105,14 @@ @;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 "+" (@;binary <type> <type> <type>)) + (@;install "-" (@;binary <type> <type> <type>)) + (@;install "*" (@;binary <type> <type> <type>)) + (@;install "/" (@;binary <type> <type> <type>)) + (@;install "%" (@;binary <type> <type> <type>)) + (@;install "=" (@;binary <type> <type> Boolean)) + (@;install "<" (@;binary <type> <type> Boolean)) + (@;install ">" (@;binary <type> <type> Boolean)) )))] [float-procs "float" Float] @@ -116,12 +123,12 @@ @;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)) + (@;install "=" (@;binary Character Character Boolean)) + (@;install "<" (@;binary Character Character Boolean)) + (@;install ">" (@;binary Character Character Boolean)) ))) -(def: primitive-boxes +(def: #export boxes (d;Dict Text Text) (|> (list ["boolean" "java.lang.Boolean"] ["byte" "java.lang.Byte"] @@ -133,21 +140,6 @@ ["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] @@ -166,34 +158,77 @@ _ (&;fail (@;wrong-amount-error proc +1 (list;size args)))))))) +(def: (invalid-array-type arrayT) + (-> Type Text) + (format "Invalid type for array: " (%type arrayT))) + (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 "'."))) + (^ (list lengthC)) + (do Monad<Lux> + [lengthA (&;with-expected-type Nat + (analyse lengthC)) + expectedT macro;expected-type + [level elem-class] (: (Lux [Nat Text]) + (loop [analysisT expectedT + level +0] + (case analysisT + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (recur outputT level) + + #;None + (&;fail (invalid-array-type expectedT))) + + (^ (#;Host "#Array" (list elemT))) + (recur elemT (n.inc level)) + + (#;Host class _) + (wrap [level class]) + + _ + (&;fail (invalid-array-type expectedT))))) + _ (&;assert "Must have at least 1 level of nesting in array type." + (n.> +0 level))] + (wrap (#la;Procedure proc (list (#la;Nat level) (#la;Text elem-class) lengthA)))) _ - (&;fail (@;wrong-amount-error proc +2 (list;size args)))))) + (&;fail (@;wrong-amount-error proc +1 (list;size args)))))) + +(def: (check-object objectT) + (-> Type (Lux Text)) + (case objectT + (#;Host name _) + (if (d;contains? name boxes) + (&;fail (format "Primitives are not objects: " name)) + (:: Monad<Lux> wrap name)) -(def: (array-load proc) + _ + (&;fail (format "Non-object type: " (%type objectT))))) + +(def: (box-array-element-type elemT) + (-> Type (Lux [Type Text])) + (do Monad<Lux> + [] + (case elemT + (#;Host name #;Nil) + (let [boxed-name (|> (d;get name boxes) + (default name))] + (wrap [(#;Host boxed-name #;Nil) + boxed-name])) + + (#;Host name _) + (if (d;contains? name boxes) + (&;fail (format "Primitives cannot be parameterized: " name)) + (:: Monad<Lux> wrap [elemT name])) + + _ + (&;fail (format "Invalid type for array element: " (%type elemT)))))) + +(def: (array-read proc) (-> Text @;Proc) (function [analyse args] (&common;with-var @@ -205,12 +240,7 @@ (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)))) + [elemT elem-class] (box-array-element-type elemT) idxA (&;with-expected-type Nat (analyse idxC)) expectedT macro;expected-type @@ -221,7 +251,7 @@ _ (&;fail (@;wrong-amount-error proc +2 (list;size args)))))))) -(def: (array-store proc) +(def: (array-write proc) (-> Text @;Proc) (function [analyse args] (&common;with-var @@ -233,15 +263,10 @@ (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)))) + [valueT elem-class] (box-array-element-type elemT) idxA (&;with-expected-type Nat (analyse idxC)) - valueA (&;with-expected-type elemT + valueA (&;with-expected-type valueT (analyse valueC)) expectedT macro;expected-type _ (&;within-type-env @@ -257,21 +282,10 @@ (|> (d;new text;Hash<Text>) (@;install "length" array-length) (@;install "new" array-new) - (@;install "load" array-load) - (@;install "store" array-store) + (@;install "read" array-read) + (@;install "write" array-write) ))) -(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] @@ -414,7 +428,7 @@ @;Bundle (<| (@;prefix "jvm") (|> (d;new text;Hash<Text>) - (d;merge converter-procs) + (d;merge conversion-procs) (d;merge int-procs) (d;merge long-procs) (d;merge float-procs) diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux new file mode 100644 index 000000000..eec4ec723 --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux @@ -0,0 +1,353 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + [text "text/" Eq<Text>] + ["R" result] + [product] + (coll [array] + [list "list/" Fold<List>] + [dict])) + ["r" math/random "r/" Monad<Random>] + [type] + [macro #+ Monad<Lux>] + (macro [code]) + test) + (luxc ["&" base] + ["&;" scope] + ["&;" module] + (lang ["~" analysis]) + [analyser] + (analyser ["@" procedure] + ["@;" common] + (procedure ["@;" host])) + (generator ["@;" runtime])) + (../.. common) + (test/luxc common)) + +(do-template [<name> <success> <failure>] + [(def: (<name> procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (&;with-scope + (&;with-expected-type output-type + (@;analyse-procedure analyse procedure params)))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + <success> + + (#R;Error error) + <failure>)))] + + [success true false] + [failure false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [<conversions> (do-template [<procedure> <from> <to>] + [(test (format <procedure> " SUCCESS") + (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>)) + (test (format <procedure> " FAILURE") + (failure <procedure> (list (' [])) <to>))] + + ["jvm convert double-to-float" "java.lang.Double" @host;Float] + ["jvm convert double-to-int" "java.lang.Double" @host;Integer] + ["jvm convert double-to-long" "java.lang.Double" @host;Long] + ["jvm convert float-to-double" "java.lang.Float" @host;Double] + ["jvm convert float-to-int" "java.lang.Float" @host;Integer] + ["jvm convert float-to-long" "java.lang.Float" @host;Long] + )] + ($_ seq + <conversions> + ))) + +(context: "Conversions [int]." + (with-expansions [<conversions> (do-template [<procedure> <from> <to>] + [(test (format <procedure> " SUCCESS") + (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>)) + (test (format <procedure> " FAILURE") + (failure <procedure> (list (' [])) <to>))] + + ["jvm convert int-to-byte" "java.lang.Integer" @host;Byte] + ["jvm convert int-to-char" "java.lang.Integer" @host;Character] + ["jvm convert int-to-double" "java.lang.Integer" @host;Double] + ["jvm convert int-to-float" "java.lang.Integer" @host;Float] + ["jvm convert int-to-long" "java.lang.Integer" @host;Long] + ["jvm convert int-to-short" "java.lang.Integer" @host;Short] + )] + ($_ seq + <conversions> + ))) + +(context: "Conversions [long]." + (with-expansions [<conversions> (do-template [<procedure> <from> <to>] + [(test (format <procedure> " SUCCESS") + (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>)) + (test (format <procedure> " FAILURE") + (failure <procedure> (list (' [])) <to>))] + + ["jvm convert long-to-double" "java.lang.Long" @host;Double] + ["jvm convert long-to-float" "java.lang.Long" @host;Float] + ["jvm convert long-to-int" "java.lang.Long" @host;Integer] + ["jvm convert long-to-short" "java.lang.Long" @host;Short] + ["jvm convert long-to-byte" "java.lang.Long" @host;Byte] + )] + ($_ seq + <conversions> + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [<conversions> (do-template [<procedure> <from> <to>] + [(test (format <procedure> " SUCCESS") + (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>)) + (test (format <procedure> " FAILURE") + (failure <procedure> (list (' [])) <to>))] + + ["jvm convert char-to-byte" "java.lang.Character" @host;Byte] + ["jvm convert char-to-short" "java.lang.Character" @host;Short] + ["jvm convert char-to-int" "java.lang.Character" @host;Integer] + ["jvm convert char-to-long" "java.lang.Character" @host;Long] + ["jvm convert byte-to-long" "java.lang.Byte" @host;Long] + ["jvm convert short-to-long" "java.lang.Short" @host;Long] + )] + ($_ seq + <conversions> + ))) + +(do-template [<domain> <boxed> <type>] + [(context: (format "Arithmetic " "[" <domain> "].") + (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] + [(test <procedure> + (success <procedure> + (list (' (_lux_coerce (+0 <subject> (+0)) [])) + (' (_lux_coerce (+0 <param> (+0)) []))) + <output>))] + + [(format "jvm " <domain> " +") <boxed> <boxed> <type>] + [(format "jvm " <domain> " -") <boxed> <boxed> <type>] + [(format "jvm " <domain> " *") <boxed> <boxed> <type>] + [(format "jvm " <domain> " /") <boxed> <boxed> <type>] + [(format "jvm " <domain> " %") <boxed> <boxed> <type>] + )] + ($_ seq + <instructions> + ))) + + (context: (format "Order " "[" <domain> "].") + (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] + [(test <procedure> + (success <procedure> + (list (' (_lux_coerce (+0 <subject> (+0)) [])) + (' (_lux_coerce (+0 <param> (+0)) []))) + <output>))] + + [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean] + )] + ($_ seq + <instructions> + ))) + + (context: (format "Bitwise " "[" <domain> "].") + (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] + [(test <procedure> + (success <procedure> + (list (' (_lux_coerce (+0 <subject> (+0)) [])) + (' (_lux_coerce (+0 <param> (+0)) []))) + <output>))] + + [(format "jvm " <domain> " and") <boxed> <boxed> <type>] + [(format "jvm " <domain> " or") <boxed> <boxed> <type>] + [(format "jvm " <domain> " xor") <boxed> <boxed> <type>] + [(format "jvm " <domain> " shl") <boxed> "java.lang.Integer" <type>] + [(format "jvm " <domain> " shr") <boxed> "java.lang.Integer" <type>] + [(format "jvm " <domain> " ushr") <boxed> "java.lang.Integer" <type>] + )] + ($_ seq + <instructions> + )))] + + + ["int" "java.lang.Integer" @host;Integer] + ["long" "java.lang.Long" @host;Long] + ) + +(do-template [<domain> <boxed> <type>] + [(context: (format "Arithmetic " "[" <domain> "].") + (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] + [(test <procedure> + (success <procedure> + (list (' (_lux_coerce (+0 <subject> (+0)) [])) + (' (_lux_coerce (+0 <param> (+0)) []))) + <output>))] + + [(format "jvm " <domain> " +") <boxed> <boxed> <type>] + [(format "jvm " <domain> " -") <boxed> <boxed> <type>] + [(format "jvm " <domain> " *") <boxed> <boxed> <type>] + [(format "jvm " <domain> " /") <boxed> <boxed> <type>] + [(format "jvm " <domain> " %") <boxed> <boxed> <type>] + )] + ($_ seq + <instructions> + ))) + + (context: (format "Order " "[" <domain> "].") + (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] + [(test <procedure> + (success <procedure> + (list (' (_lux_coerce (+0 <subject> (+0)) [])) + (' (_lux_coerce (+0 <param> (+0)) []))) + <output>))] + + [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean] + )] + ($_ seq + <instructions> + )))] + + + ["float" "java.lang.Float" @host;Float] + ["double" "java.lang.Double" @host;Double] + ) + +(do-template [<domain> <boxed> <type>] + [(context: (format "Order " "[" <domain> "].") + (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] + [(test <procedure> + (success <procedure> + (list (' (_lux_coerce (+0 <subject> (+0)) [])) + (' (_lux_coerce (+0 <param> (+0)) []))) + <output>))] + + [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean] + )] + ($_ seq + <instructions> + )))] + + + ["char" "java.lang.Character" @host;Character] + ) + +(def: array-type + (r;Random [Text Text]) + (let [entries (dict;entries @host;boxes) + num-entries (list;size entries)] + (do r;Monad<Random> + [choice (|> r;nat (:: @ map (n.% (n.inc num-entries)))) + #let [[unboxed boxed] (: [Text Text] + (|> entries + (list;nth choice) + (default ["java.lang.Object" "java.lang.Object"])))]] + (wrap [unboxed boxed])))) + +(context: "Array." + [#let [cap (|>. (n.% +10) (n.max +1))] + [unboxed boxed] array-type + size (|> r;nat (:: @ map cap)) + idx (|> r;nat (:: @ map (n.% size))) + level (|> r;nat (:: @ map cap)) + #let [unboxedT (#;Host unboxed (list)) + arrayT (#;Host "#Array" (list unboxedT)) + arrayC (`' (_lux_check (+0 "#Array" (+1 (+0 (~ (code;text unboxed)) (+0)) (+0))) + ("jvm array new" (~ (code;nat size))))) + boxedT (#;Host boxed (list)) + boxedTC (` (+0 (~ (code;text boxed)) (+0))) + multi-arrayT (list/fold (function [_ innerT] + (|> innerT (list) (#;Host "#Array"))) + boxedT + (list;n.range +1 level))]] + ($_ seq + (test "jvm array new" + (success "jvm array new" + (list (code;nat size)) + arrayT)) + (test "jvm array new (no nesting)" + (failure "jvm array new" + (list (code;nat size)) + unboxedT)) + (test "jvm array new (nested/multi-level)" + (success "jvm array new" + (list (code;nat size)) + multi-arrayT)) + (test "jvm array length" + (success "jvm array length" + (list arrayC) + Nat)) + (test "jvm array read" + (success "jvm array read" + (list arrayC (code;nat idx)) + boxedT)) + (test "jvm array write" + (success "jvm array write" + (list arrayC (code;nat idx) (`' (_lux_coerce (~ boxedTC) []))) + arrayT)) + )) + +(def: throwables + (List Text) + (list "java.lang.Throwable" + "java.lang.Error" + "java.io.IOError" + "java.lang.VirtualMachineError" + "java.lang.Exception" + "java.io.IOException" + "java.lang.RuntimeException")) + +(context: "Object." + [[unboxed boxed] array-type + #let [boxedT (#;Host boxed (list)) + boxedC (`' (_lux_check (+0 (~ (code;text boxed)) (+0)) + ("jvm object null"))) + unboxedC (`' (_lux_check (+0 (~ (code;text unboxed)) (+0)) + ("jvm object null")))] + throwable (|> r;nat + (:: @ map (n.% (n.inc (list;size throwables)))) + (:: @ map (function [idx] + (|> throwables + (list;nth idx) + (default "java.lang.Object"))))) + #let [throwableC (`' (_lux_check (+0 (~ (code;text throwable)) (+0)) + ("jvm object null")))]] + ($_ seq + (test "jvm object null" + (success "jvm object null" + (list) + (#;Host boxed (list)))) + (test "jvm object null (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object null" + (list) + (#;Host unboxed (list))))) + (test "jvm object null?" + (success "jvm object null?" + (list boxedC) + Bool)) + (test "jvm object synchronized" + (success "jvm object synchronized" + (list boxedC boxedC) + boxedT)) + (test "jvm object synchronized (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object synchronized" + (list unboxedC boxedC) + boxedT))) + (test "jvm object throw" + (or (text/= "java.lang.Object" throwable) + (success "jvm object throw" + (list throwableC) + Bottom))) + (test "jvm object class" + (success "jvm object class" + (list (code;text boxed)) + (#;Host "java.lang.Class" (list boxedT)))) + )) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 28ccefc42..311b6666f 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -12,7 +12,8 @@ ["_;A" case] ["_;A" function] ["_;A" type] - (procedure ["_;A" common])) + (procedure ["_;A" common] + ["_;A" host])) (synthesizer ["_;S" primitive] ["_;S" structure] (case ["_;S" special]) |