diff options
author | Eduardo Julian | 2017-10-04 22:02:41 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-10-04 22:02:41 -0400 |
commit | 29228f5c601d8d5d42aa5352566a609bf4259d11 (patch) | |
tree | 4bd9ee826f07c131e921eaf8e31d9efe309b9c6f /new-luxc/source/luxc/analyser/procedure/host.jvm.lux | |
parent | 36b89b978e8bc6f084e67a11207488ea2fe25c72 (diff) |
- WIP: JVM host procedure analysis.
Diffstat (limited to 'new-luxc/source/luxc/analyser/procedure/host.jvm.lux')
-rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 425 |
1 files changed, 425 insertions, 0 deletions
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) + ))) |