aboutsummaryrefslogtreecommitdiff
path: root/source/lux
diff options
context:
space:
mode:
Diffstat (limited to 'source/lux')
-rw-r--r--source/lux/host/jvm.lux122
-rw-r--r--source/lux/meta/syntax.lux40
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 [<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)))))))
+ ))
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 [<name> <type> <tag> <eq>]
[(def #export (<name> v tokens)
- (-> <type> (Parser (,)))
+ (-> <type> (Parser Bool))
(case tokens
(#;Cons [[_ (<tag> x)] tokens'])
- (if (<eq> v x)
- (#;Some [tokens' []])
- #;None)
+ (#;Some [tokens' (<eq> 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 20:17:02 +0000