From 4cd9b0c9242f1105e50ad9b42b7f6f5d074f14b4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Jul 2015 20:19:43 -0400 Subject: - The output directory is now being used as the cache. - "input" has been renamed as "source" and "output" has been renamed as "target". --- source/lux/host/java.lux | 312 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 312 insertions(+) create mode 100644 source/lux/host/java.lux (limited to 'source/lux/host') diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux new file mode 100644 index 000000000..12525d3f2 --- /dev/null +++ b/source/lux/host/java.lux @@ -0,0 +1,312 @@ +## 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 + (text #as text)) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (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^ + _ end^] + (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^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (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^ + _ end^] + (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^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;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^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;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 [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;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)) + [(~@ (:: List/Functor (F;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_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ 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) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ 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) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (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^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) -- cgit v1.2.3 From 9b7cfd6f5bcc93e2f2f0c3129b7ec6d62c69bb37 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Jul 2015 20:57:21 -0400 Subject: - Fixed a pattern-matching error where generalizations of types (universal-quantification / AllT) was not being taken into account properly when destructuring. - Fixed a compiler error wherein the types of definitions didn't generate (correctly) the structures necessary for storage inside the class _meta(data) field. - Improved both the "open" and "import" macros with extra features. --- source/lux/host/java.lux | 84 +++++++++++++++++++++++------------------------- 1 file changed, 41 insertions(+), 43 deletions(-) (limited to 'source/lux/host') diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux index 12525d3f2..9bd0c838c 100644 --- a/source/lux/host/java.lux +++ b/source/lux/host/java.lux @@ -10,14 +10,12 @@ (lux (control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) - (data list + (data (list #as l #refer #all #open ("" List/Functor)) (text #as text)) (meta lux macro syntax))) -## (open List/Functor) - ## [Utils/Parsers] (def finally^ (Parser Syntax) @@ -110,29 +108,29 @@ (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) (emit (list (` (_jvm_try (~ body) - (~@ (list:++ (:: List/Functor (F;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)))))))))))) + (~@ (:: 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^)]) (do Lux/Monad [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name))]] - (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - members))] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] (~@ members')))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] @@ -142,35 +140,35 @@ [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name)) - fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - fields)) - methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs)))] - (~ (text$ output)) - [(~@ (:: List/Functor (F;map text$ modifiers)))] - (~ body)))))) - methods))]] + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" 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] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ (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)) - [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ (map text$ arg-classes))] [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) -- cgit v1.2.3 From 8fb7683f9029127be9cf36336c367813c88f681b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Jul 2015 23:09:47 -0400 Subject: - Changed the name of lux/host/java to lux/host/jvm - Completed lux/host/jvm - Modified (slightly) the syntax used in several host (JVM) special forms. - The "defsyntax" macro now binds all of the arguments it receives inside a variable named "tokens". --- source/lux/host/java.lux | 310 ----------------------------------------------- source/lux/host/jvm.lux | 270 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 270 insertions(+), 310 deletions(-) delete mode 100644 source/lux/host/java.lux create mode 100644 source/lux/host/jvm.lux (limited to 'source/lux/host') diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux deleted file mode 100644 index 9bd0c838c..000000000 --- a/source/lux/host/java.lux +++ /dev/null @@ -1,310 +0,0 @@ -## 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^ - _ end^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^ - _ end^] - (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^ - _ end^] - (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^ - _ end^] - (M;wrap [modifiers name class])))) - -(def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] - (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^ - _ end^] - (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^)) - _ end^ - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) - -## [Utils/Lux] -## (def (find-class-field field class) -## (-> Text Text (Lux Type)) -## ...) - -## (def (find-virtual-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - -## (def (find-static-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - - -## [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^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ full-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 [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" 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] - (` ((~ (symbol$ ["" name])) - [(~@ (map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (list (` (_jvm_class (~ (text$ full-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_monitor-enter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ 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) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) - -## _ -## (fail "Can only get field from object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.? (~ 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) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) - -## _ -## (fail "Can only set field of object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.= (~ field) (~ value) (~ g!obj))))))))) - -## (defsyntax #export (.! [call method-call^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-virtual-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] -## (~ obj) [(~@ m-args)]))))) - -## _ -## (fail "Can only call method on object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.! (~@ *tokens*))))))))) - -## (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^]) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-static-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) -## [(~@ (:: List/Functor (F;map text$ m-ins)))] -## [(~@ m-args)])))) -## )) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux new file mode 100644 index 000000000..a3a74d608 --- /dev/null +++ b/source/lux/host/jvm.lux @@ -0,0 +1,270 @@ +## 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^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (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^ + _ end^] + (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^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (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^ + _ end^] + (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^)) + _ end^ + _ (: (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^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-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 [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" 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] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] + (emit (list (` (_jvm_class (~ (text$ full-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_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ 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) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (let [[m-name ?m-classes m-args] call] + (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)] + (.! (~@ *tokens*))))))))) + +(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)])))))) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) -- cgit v1.2.3 From c79621772c862e9b94e1fc43e11996cbac54fed1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 29 Jul 2015 20:20:26 -0400 Subject: - lux;using no longer prefixes variables. - Fixed several bugs with host (JVM) interop. - Now packaging everything in a .jar file ("program.jar"). --- source/lux/host/jvm.lux | 108 +++++++++++++++++------------------------------- 1 file changed, 38 insertions(+), 70 deletions(-) (limited to 'source/lux/host') diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index a3a74d608..7af043969 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -22,8 +22,7 @@ (Parser Syntax) (form^ (do Parser/Monad [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] + expr id^] (M;wrap expr)))) (def catch^ @@ -32,8 +31,7 @@ [_ (symbol?^ ["" "catch"]) ex-class local-symbol^ ex symbol^ - expr id^ - _ end^] + expr id^] (M;wrap [ex-class ex expr])))) (def method-decl^ @@ -42,8 +40,7 @@ [modifiers (*^ local-tag^) name local-symbol^ inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] + output local-symbol^] (M;wrap [modifiers name inputs output])))) (def field-decl^ @@ -51,16 +48,14 @@ (form^ (do Parser/Monad [modifiers (*^ local-tag^) name local-symbol^ - class local-symbol^ - _ end^] + 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^ - _ end^] + arg-class local-symbol^] (M;wrap [arg-name arg-class])))) (def method-def^ @@ -70,8 +65,7 @@ name local-symbol^ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ - body id^ - _ end^] + body id^] (M;wrap [modifiers name inputs output body])))) (def method-call^ @@ -80,7 +74,6 @@ [method local-symbol^ arity-classes (tuple^ (*^ local-symbol^)) arity-args (tuple^ (*^ id^)) - _ end^ _ (: (Parser (,)) (if (i= (size arity-classes) (size arity-args)) @@ -108,47 +101,41 @@ (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] - (~@ members')))))))) + (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 [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (map (: (-> (, (List Text) Text Text) Syntax) + #let [fields' (map (: (-> (, (List Text) Text Text) Syntax) (lambda [field] (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) + (` ((~ (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] - (` ((~ (symbol$ ["" name])) + (` ((~ (text$ name)) [(~@ (map (: (-> (, Text Text) Syntax) (lambda [in] (let [[left right] in] - (form$ (list (text$ left) + (form$ (list (symbol$ ["" left]) (text$ right)))))) inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))] (~ body)))))) methods)]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) [(~@ (map text$ interfaces))] [(~@ fields')] [(~@ methods')])))))) @@ -166,9 +153,9 @@ [g!lock (gensym "") g!body (gensym "")] (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) + _ (_jvm_monitorenter (~ g!lock)) (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] + _ (_jvm_monitorexit (~ g!lock))] (~ g!body))))) )) @@ -216,24 +203,27 @@ (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) (defsyntax #export (.! [call method-call^] obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (let [[m-name ?m-classes m-args] call] + (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)]))))) + (~ obj) [(~@ m-args)])))) - _ - (fail "Can only call method on object."))) + _ + (fail "Can only call method on object."))) - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! (~@ *tokens*))))))))) + _ + (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))))))) @@ -246,25 +236,3 @@ (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ m-classes))] [(~@ m-args)])))))) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) -- cgit v1.2.3