diff options
Diffstat (limited to 'source/lux/host/jvm.lux')
| -rw-r--r-- | source/lux/host/jvm.lux | 109 |
1 files changed, 55 insertions, 54 deletions
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 40021d8fa..d7992509a 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -82,21 +82,21 @@ ## [Syntax] (defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) + (emit (list (` (;_jvm_throw (~ ex)))))) (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (: (List AST) (list (` (_jvm_finally (~ finally)))))))))))))) + (emit (list (` (;_jvm_try (~ body) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) + (lambda [catch] + (let [[class ex body] catch] + (` (;_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (: (List AST) (list (` (;_jvm_finally (~ finally)))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) @@ -104,8 +104,8 @@ (let [[modifiers name inputs output] member] (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) members)] - (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) + (emit (list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ members'))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] @@ -133,36 +133,37 @@ [(~@ (map text$ modifiers))] (~ body)))))) methods)]] - (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) + (emit (list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ fields')] + [(~@ methods')])))))) (defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) + (emit (list (` (;_jvm_new (~ (text$ class)) + [(~@ (map text$ arg-classes))] + [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + (emit (list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) (defsyntax #export (locking lock body) (do Lux/Monad [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitorexit (~ g!lock))] - (~ g!body))))) + 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)))))) + (emit (list (` (;_jvm_null? (~ obj)))))) (defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) + (emit (list (` (;_jvm_program (~ (symbol$ args)) + (~ body)))))) (defsyntax #export (.? [field local-symbol^] obj) (case obj @@ -171,7 +172,7 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) + (emit (list (` (;_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) _ (fail "Can only get field from object."))) @@ -179,8 +180,8 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.? (~ (text$ field)) (~ g!obj))))))))) + (emit (list (` (let [(~ g!obj) (~ obj)] + (;;.? (~ (text$ field)) (~ g!obj))))))))) (defsyntax #export (.= [field local-symbol^] value obj) (case obj @@ -189,7 +190,7 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) + (emit (list (` (;_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) _ (fail "Can only set field of object."))) @@ -197,8 +198,8 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) + (emit (list (` (let [(~ g!obj) (~ obj)] + (;;.= (~ (text$ field)) (~ value) (~ g!obj))))))))) (defsyntax #export (.! [call method-call^] obj) (let [[m-name ?m-classes m-args] call] @@ -208,8 +209,8 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)])))) + (emit (list (` (;_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] + (~ obj) [(~@ m-args)])))) _ (fail "Can only call method on object."))) @@ -217,31 +218,31 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! ((~ (symbol$ ["" m-name])) - [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] - [(~@ m-args)]) - (~ g!obj)))))))))) + (emit (list (` (let [(~ g!obj) (~ obj)] + (;;.! ((~ (symbol$ ["" m-name])) + [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] + [(~@ m-args)]) + (~ g!obj)))))))))) (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) - (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + (emit (list (` (;_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) - (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + (emit (list (` (;_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) (defsyntax #export (..! [call method-call^] [class local-symbol^]) (let [[m-name m-classes m-args] call] - (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) - [(~@ (map text$ m-classes))] - [(~@ m-args)])))))) + (emit (list (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) + [(~@ (map text$ m-classes))] + [(~@ m-args)])))))) (defsyntax #export (->maybe expr) (do Lux/Monad [g!val (gensym "")] - (emit (list (` (;let [(~ g!val) (~ expr)] - (;if (null? (~ g!val)) - #;None - (#;Some (~ g!val))))))))) + (emit (list (` (let [(~ g!val) (~ expr)] + (if (null? (~ g!val)) + #;None + (#;Some (~ g!val))))))))) (defsyntax #export (try$ expr) (emit (list (` (try (#;Right (~ expr)) |