From 2f2a37639e7933d97bd0dd4b790e92ff7e784dcf Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 13 Sep 2015 00:11:32 -0400 Subject: - Expanded the lux/host/jvm library. --- source/lux/host/jvm.lux | 122 ++++++++++++++++++++++++++++++++++++++++++++- source/lux/meta/syntax.lux | 40 +++++++-------- 2 files changed, 138 insertions(+), 24 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 [ ] + [(defsyntax #export ( [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 (` ( (~ (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))))))) + )) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 5425a2d9c..a28fa6d27 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -107,15 +107,13 @@ (do-template [ ] [(def #export ( v tokens) - (-> (Parser (,))) + (-> (Parser Bool)) (case tokens (#;Cons [[_ ( x)] tokens']) - (if ( v x) - (#;Some [tokens' []]) - #;None) + (#;Some [tokens' ( v x)]) _ - #;None))] + (#;Some [tokens false])))] [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] [ int?^ Int #;IntS i=] @@ -220,24 +218,22 @@ (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] body)) (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [arg] - (case arg - (\ [_ (#;TupleS (@list [_ (#;SymbolS var-name)] - parser))]) - (wrap [(symbol$ var-name) parser]) - - (\ [_ (#;SymbolS var-name)]) - (wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) + [vars+parsers (M;map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [arg] + (case arg + (\ [_ (#;TupleS (@list var parser))]) + (wrap [var parser]) + + (\ [_ (#;SymbolS var-name)]) + (wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) g!tokens (gensym "tokens") g!_ (gensym "_") - #let [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) + #let [error-msg (text$ (text:++ "Wrong syntax for " name)) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body name+parser] (let [[name parser] name+parser] @@ -248,7 +244,7 @@ (~ g!_) (l;fail (~ error-msg))))))) body - (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) + (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers)))) macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body')))]] (wrap (@list& macro-def -- cgit v1.2.3