diff options
Diffstat (limited to 'source/lux/host/jvm.lux')
| -rw-r--r-- | source/lux/host/jvm.lux | 122 |
1 files changed, 120 insertions, 2 deletions
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index ba29925a7..710bc9a20 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -6,14 +6,17 @@ (;import lux (lux (control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) + (monad #as M #refer (#only do seq%))) (data (list #refer #all #open ("" List/Functor List/Fold)) (number/int #refer #all #open ("i:" Int/Ord)) - maybe) + maybe + tuple) (meta lux ast syntax))) +(open List/Monad "list:") + ## [Utils] ## Parsers (def method-decl^ @@ -50,6 +53,11 @@ body id^] (wrap [modifiers name inputs output body])))) +(def opt-arg^ + (Parser (, Bool Text)) + (&^ (tag?^ ["" "?"]) + local-symbol^)) + ## [Syntax] (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) @@ -115,3 +123,113 @@ type (repeat dimensions [])))) (fail "Array must have positive dimension.")))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "") + g!_ (gensym "")] + (emit (@list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (@list (` (;_jvm_null? (~ obj)))))) + +(def (prepare-args args) + (-> (List (, Bool Text)) (Lux (, (List AST) (List AST) (List AST) (List Text)))) + (do Lux/Monad + [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) + #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) + (lambda [[[opt? arg-class] var]] + (if opt? + [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) + (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) + (case (~ var) + (#;Some (~ var)) (~ var) + #;None ;_jvm_null))))] + [(` (^ (~ (symbol$ ["" arg-class])))) + (@list)]))) + (zip2 args vars)) + var-types (map first pairings) + var-rebinds (map second pairings) + arg-classes (map second args)]] + (wrap [vars var-types (list:join var-rebinds) arg-classes]))) + +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ opt-arg^))]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args)] + (case vars + (\ (@list)) + (do Lux/Monad + [g!_ (gensym "")] + (wrap (@list (` (: (-> (,) (^ (~ (symbol$ ["" class])))) + (lambda [(~ g!_)] + (;_jvm_new (~ (text$ class)) [] []))))))) + + _ + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))))))) + ))) + +(do-template [<name> <op>] + [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] + [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args) + g!self (gensym "self") + g!temp (gensym "temp") + #let [return-type (` (^ (~ (symbol$ ["" return])))) + body (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])) + [body return-type] (if opt? + [(` (let [(~ g!temp) (~ body)] + (if (;_jvm_null? (~ g!temp)) + #;None + (#;Some (~ g!temp))))) + (` (Maybe (~ return-type)))] + [body return-type]) + [body return-type] (if ex? + [(` (try (~ body))) + (` (Either Text (~ return-type)))] + [body return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) + (lambda [[(~@ vars)] (~ g!self)] + (let [(~@ var-rebinds)] + (~ body))))))) + ))] + + [invoke-virtual$ ;_jvm_invokevirtual] + [invoke-interface$ ;_jvm_invokeinterface] + ) + +(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] + [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args) + g!temp (gensym "temp") + #let [return-type (` (^ (~ (symbol$ ["" return])))) + body (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])) + [body return-type] (if opt? + [(` (let [(~ g!temp) (~ body)] + (if (;_jvm_null? (~ g!temp)) + #;None + (#;Some (~ g!temp))))) + (` (Maybe (~ return-type)))] + [body return-type]) + [body return-type] (if ex? + [(` (try (~ body))) + (` (Either Text (~ return-type)))] + [body return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (~ body))))))) + )) |