Merge pull request #4 from LuxLang/v0.2

V0.2

1 files changed, 238 insertions, 0 deletions

diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux
new file mode 100644
index 000000000..7af043969
--- /dev/null
+++ b/source/lux/host/jvm.lux
@@ -0,0 +1,238 @@
+##   Copyright (c) Eduardo Julian. All rights reserved.
+##   The use and distribution terms for this software are covered by the
+##   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+##   which can be found in the file epl-v10.html at the root of this distribution.
+##   By using this software in any fashion, you are agreeing to be bound by
+##   the terms of this license.
+##   You must not remove this notice, or any other, from this software.
+
+(;import lux
+         (lux (control (monoid #as m)
+                       (functor #as F)
+                       (monad #as M #refer (#only do)))
+              (data (list #as l #refer #all #open ("" List/Functor))
+                    (text #as text))
+              (meta lux
+                    macro
+                    syntax)))
+
+## [Utils]
+## Parsers
+(def finally^
+  (Parser Syntax)
+  (form^ (do Parser/Monad
+           [_ (symbol?^ ["" "finally"])
+            expr id^]
+           (M;wrap expr))))
+
+(def catch^
+  (Parser (, Text Ident Syntax))
+  (form^ (do Parser/Monad
+           [_ (symbol?^ ["" "catch"])
+            ex-class local-symbol^
+            ex symbol^
+            expr id^]
+           (M;wrap [ex-class ex expr]))))
+
+(def method-decl^
+  (Parser (, (List Text) Text (List Text) Text))
+  (form^ (do Parser/Monad
+           [modifiers (*^ local-tag^)
+            name local-symbol^
+            inputs (tuple^ (*^ local-symbol^))
+            output local-symbol^]
+           (M;wrap [modifiers name inputs output]))))
+
+(def field-decl^
+  (Parser (, (List Text) Text Text))
+  (form^ (do Parser/Monad
+           [modifiers (*^ local-tag^)
+            name local-symbol^
+            class local-symbol^]
+           (M;wrap [modifiers name class]))))
+
+(def arg-decl^
+  (Parser (, Text Text))
+  (form^ (do Parser/Monad
+           [arg-name local-symbol^
+            arg-class local-symbol^]
+           (M;wrap [arg-name arg-class]))))
+
+(def method-def^
+  (Parser (, (List Text) Text (List (, Text Text)) Text Syntax))
+  (form^ (do Parser/Monad
+           [modifiers (*^ local-tag^)
+            name local-symbol^
+            inputs (tuple^ (*^ arg-decl^))
+            output local-symbol^
+            body id^]
+           (M;wrap [modifiers name inputs output body]))))
+
+(def method-call^
+  (Parser (, Text (List Text) (List Syntax)))
+  (form^ (do Parser/Monad
+           [method local-symbol^
+            arity-classes (tuple^ (*^ local-symbol^))
+            arity-args (tuple^ (*^ id^))
+            _ (: (Parser (,))
+                 (if (i= (size arity-classes)
+                         (size arity-args))
+                   (M;wrap [])
+                   (lambda [_] #;None)))]
+           (M;wrap [method arity-classes arity-args])
+           )))
+
+## [Syntax]
+(defsyntax #export (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 Syntax) Syntax)
+                                                             (lambda [catch]
+                                                               (let [[class ex body] catch]
+                                                                 (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body))))))
+                                                          catches)
+                                                     (case finally
+                                                       #;None
+                                                       (list)
+
+                                                       (#;Some finally)
+                                                       (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) Syntax)
+                         (lambda [member]
+                           (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')))))))
+
+(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
+                     [fields (*^ field-decl^)]
+                     [methods (*^ method-def^)])
+  (do Lux/Monad
+    [current-module get-module-name
+     #let [fields' (map (: (-> (, (List Text) Text Text) Syntax)
+                           (lambda [field]
+                             (let [[modifiers name class] field]
+                               (` ((~ (text$ name))
+                                   (~ (text$ class))
+                                   [(~@ (map text$ modifiers))])))))
+                        fields)
+           methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax)
+                            (lambda [methods]
+                              (let [[modifiers name inputs output body] methods]
+                                (` ((~ (text$ name))
+                                    [(~@ (map (: (-> (, Text Text) Syntax)
+                                                 (lambda [in]
+                                                   (let [[left right] in]
+                                                     (form$ (list (symbol$ ["" left])
+                                                                  (text$ right))))))
+                                              inputs))]
+                                    (~ (text$ output))
+                                    [(~@ (map text$ modifiers))]
+                                    (~ body))))))
+                         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)])))))
+
+(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 "")]
+    (emit (list (` (;let [(~ g!lock) (~ lock)
+                          _ (_jvm_monitorenter (~ g!lock))
+                          (~ g!body) (~ body)
+                          _ (_jvm_monitorexit (~ g!lock))]
+                         (~ g!body)))))
+    ))
+
+(defsyntax #export (null? obj)
+  (emit (list (` (_jvm_null? (~ obj))))))
+
+(defsyntax #export (program [args symbol^] body)
+  (emit (list (` (_jvm_program (~ (symbol$ args))
+                   (~ body))))))
+
+(defsyntax #export (.? [field local-symbol^] obj)
+  (case obj
+    (#;Meta [_ (#;SymbolS obj-name)])
+    (do Lux/Monad
+      [obj-type (find-var-type obj-name)]
+      (case obj-type
+        (#;DataT class)
+        (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field))))))
+
+        _
+        (fail "Can only get field from object.")))
+
+    _
+    (do Lux/Monad
+      [g!obj (gensym "")]
+      (emit (list (` (;let [(~ g!obj) (~ obj)]
+                           (.? (~ (text$ field)) (~ g!obj)))))))))
+
+(defsyntax #export (.= [field local-symbol^] value obj)
+  (case obj
+    (#;Meta [_ (#;SymbolS obj-name)])
+    (do Lux/Monad
+      [obj-type (find-var-type obj-name)]
+      (case obj-type
+        (#;DataT class)
+        (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value)))))
+
+        _
+        (fail "Can only set field of object.")))
+
+    _
+    (do Lux/Monad
+      [g!obj (gensym "")]
+      (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]
+    (case obj
+      (#;Meta [_ (#;SymbolS obj-name)])
+      (do Lux/Monad
+        [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)]))))
+
+          _
+          (fail "Can only call method on object.")))
+
+      _
+      (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))))))))))
+
+(defsyntax #export (..? [field local-symbol^] [class local-symbol^])
+  (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))))))
+
+(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)]))))))