aboutsummaryrefslogtreecommitdiff
path: root/source/lux/host/jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux/host/jvm.lux543
1 files changed, 341 insertions, 202 deletions
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux
index 7af043969..737c1731d 100644
--- a/source/lux/host/jvm.lux
+++ b/source/lux/host/jvm.lux
@@ -1,238 +1,377 @@
-## 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.
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
(;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))
+ (monad #as M #refer (#only do seq%))
+ (enum #as E))
+ (data (list #refer #all #open ("" List/Functor List/Fold))
+ (number/int #refer #all #open ("i:" Int/Ord Int/Number))
+ maybe
+ tuple
+ (text #open ("text:" Text/Monoid)))
(meta lux
- macro
+ ast
syntax)))
+(open List/Monad "list:")
+
+## [Types]
+(defsyntax #export (Array [dimensions (?^ nat^)] type)
+ (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner)))))
+ type
+ (repeat (? 1 dimensions) [])))))
+
## [Utils]
+## Types
+(deftype StackFrame (^ java.lang.StackTraceElement))
+(deftype StackTrace (Array StackFrame))
+
+(deftype Modifier Text)
+(deftype JvmType Text)
+
+(deftype AnnotationParam
+ (, Text AST))
+
+(deftype Annotation
+ (& #ann-name Text
+ #ann-params (List AnnotationParam)))
+
+(deftype MemberDecl
+ (& #member-name Text
+ #member-modifiers (List Modifier)
+ #member-anns (List Annotation)))
+
+(deftype FieldDecl
+ JvmType)
+
+(deftype MethodDecl
+ (& #method-inputs (List JvmType)
+ #method-output JvmType
+ #method-exs (List JvmType)))
+
+(deftype ArgDecl
+ (& #arg-name Text
+ #arg-type JvmType))
+
+(deftype MethodDef
+ (& #method-vars (List ArgDecl)
+ #return-type JvmType
+ #return-body AST
+ #throws-exs (List JvmType)))
+
+(deftype ExpectedInput
+ (& #opt-input? Bool
+ #input-type JvmType))
+
+(deftype ExpectedOutput
+ (& #ex-output? Bool
+ #opt-output? Bool
+ #output-type JvmType))
+
+## Functions
+(def (prepare-args args)
+ (-> (List ExpectedInput) (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])))
+
+(def (class->type class)
+ (-> JvmType AST)
+ (case class
+ "boolean" (' (;^ java.lang.Boolean))
+ "byte" (' (;^ java.lang.Byte))
+ "short" (' (;^ java.lang.Short))
+ "int" (' (;^ java.lang.Integer))
+ "long" (' (;^ java.lang.Long))
+ "float" (' (;^ java.lang.Float))
+ "double" (' (;^ java.lang.Double))
+ "char" (' (;^ java.lang.Character))
+ "void" (` ;Unit)
+ _
+ (` (^ (~ (symbol$ ["" class]))))))
+
## 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 annotation-params^
+ (Parser (List AnnotationParam))
+ (record^ (*^ (tuple^ (&^ local-tag^ id^)))))
+
+(def annotation^
+ (Parser Annotation)
+ (form^ (&^ local-symbol^
+ annotation-params^)))
+
+(def annotations^'
+ (Parser (List Annotation))
+ (do Parser/Monad
+ [_ (tag!^ ["" "ann"])]
+ (tuple^ (*^ annotation^))))
+
+(def annotations^
+ (Parser (List Annotation))
+ (do Parser/Monad
+ [anns?? (?^ annotations^')]
+ (wrap (? (@list) anns??))))
+
+(def member-decl^
+ (Parser MemberDecl)
+ (do Parser/Monad
+ [modifiers (*^ local-tag^)
+ name local-symbol^
+ anns annotations^]
+ (wrap [name modifiers anns])))
+
+(def throws-decl'^
+ (Parser (List JvmType))
+ (do Parser/Monad
+ [_ (tag!^ ["" "throws"])]
+ (tuple^ (*^ local-symbol^))))
+
+(def throws-decl^
+ (Parser (List JvmType))
+ (do Parser/Monad
+ [exs? (?^ throws-decl'^)]
+ (wrap (? (@list) exs?))))
+
+(def method-decl'^
+ (Parser MethodDecl)
+ (do Parser/Monad
+ [inputs (tuple^ (*^ local-symbol^))
+ outputs local-symbol^
+ exs throws-decl^]
+ (wrap [inputs outputs exs])))
(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]))))
+ (Parser (, MemberDecl MethodDecl))
+ (form^ (&^ member-decl^
+ method-decl'^)))
(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]))))
+ (Parser (, MemberDecl FieldDecl))
+ (form^ (&^ member-decl^
+ local-symbol^)))
(def arg-decl^
- (Parser (, Text Text))
- (form^ (do Parser/Monad
- [arg-name local-symbol^
- arg-class local-symbol^]
- (M;wrap [arg-name arg-class]))))
+ (Parser ArgDecl)
+ (form^ (&^ local-symbol^ local-symbol^)))
+
+(def method-def'^
+ (Parser MethodDef)
+ (do Parser/Monad
+ [inputs (tuple^ (*^ arg-decl^))
+ output local-symbol^
+ exs throws-decl^
+ body id^]
+ (wrap [inputs output body exs])))
(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])
- )))
+ (Parser (, MemberDecl MethodDef))
+ (form^ (&^ member-decl^
+ method-def'^)))
-## [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')))))))
+(def exp-input^
+ (Parser ExpectedInput)
+ (&^ (tag?^ ["" "?"])
+ local-symbol^))
+
+(def exp-output^
+ (Parser ExpectedOutput)
+ (do Parser/Monad
+ [ex? (tag?^ ["" "!"])
+ opt? (tag?^ ["" "?"])
+ return local-symbol^]
+ (wrap [ex? opt? return])))
+
+## Generators
+(def (gen-annotation-param [name value])
+ (-> AnnotationParam (, AST AST))
+ [(text$ name) value])
+
+(def (gen-annotation [name params])
+ (-> Annotation AST)
+ (` ((~ (text$ name))
+ (~ (record$ (map gen-annotation-param params))))))
+
+(def (gen-method-decl [[name modifiers anns] [inputs output exs]])
+ (-> (, MemberDecl MethodDecl) AST)
+ (` ((~ (text$ name))
+ [(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
+ [(~@ (map text$ exs))]
+ [(~@ (map text$ inputs))]
+ (~ (text$ output)))))
+
+(def (gen-field-decl [[name modifiers anns] class])
+ (-> (, MemberDecl FieldDecl) AST)
+ (` ((~ (text$ name))
+ [(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
+ (~ (text$ class))
+ )))
+
+(def (gen-arg-decl [name type])
+ (-> ArgDecl AST)
+ (form$ (@list (symbol$ ["" name]) (text$ type))))
+(def (gen-method-def [[name modifiers anns] [inputs output body exs]])
+ (-> (, MemberDecl MethodDef) AST)
+ (` ((~ (text$ name))
+ [(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
+ [(~@ (map text$ exs))]
+ [(~@ (map gen-arg-decl inputs))]
+ (~ (text$ output))
+ (~ body))))
+
+(def (gen-expected-output [ex? opt? output] body)
+ (-> ExpectedOutput AST (, AST AST))
+ (let [type (class->type output)
+ [body type] (if opt?
+ [(` (;;??? (~ body)))
+ (` (Maybe (~ type)))]
+ [body type])
+ [body type] (if ex?
+ [(` (;;try (~ body)))
+ (` (Either Text (~ type)))]
+ [body type])]
+ [body type]))
+
+## [Functions]
+(def (stack-trace->text trace)
+ (-> StackTrace Text)
+ (let [size (_jvm_arraylength trace)
+ idxs (E;range Int/Enum 0 (i:+ -1 size))]
+ (|> idxs
+ (map (: (-> Int Text)
+ (lambda [idx]
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload trace idx) []))))
+ (interpose "\n")
+ (foldL text:++ "")
+ )))
+
+(def (get-stack-trace t)
+ (-> (^ java.lang.Throwable) StackTrace)
+ (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t []))
+
+(def #export (throwable->text t)
+ (-> (^ java.lang.Throwable) Text)
+ ($ text:++
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] t [])
+ "\n"
+ (|> t get-stack-trace stack-trace->text)))
+
+## [Syntax]
(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
+ [annotations annotations^]
[fields (*^ field-decl^)]
[methods (*^ method-def^)])
+ (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super))
+ [(~@ (map text$ interfaces))]
+ [(~@ (map gen-annotation annotations))]
+ [(~@ (map gen-field-decl fields))]
+ [(~@ (map gen-method-def methods))])))))
+
+(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))]
+ [annotations annotations^]
+ [members (*^ method-decl^)])
+ (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
+ [(~@ (map gen-annotation annotations))]
+ (~@ (map gen-method-decl members)))))))
+
+(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
+ [methods (*^ method-def^)])
+ (emit (@list (` (;_jvm_anon-class (~ (text$ super))
+ [(~@ (map text$ interfaces))]
+ [(~@ (map gen-method-def methods))])))))
+
+(defsyntax #export (program [args symbol^] body)
+ (emit (@list (` (;_jvm_program (~ (symbol$ args))
+ (~ body))))))
+
+(defsyntax #export (??? expr)
(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)])))))
+ [g!temp (gensym "")]
+ (wrap (@list (` (let [(~ g!temp) (~ expr)]
+ (if (;_jvm_null? (~ g!temp))
+ #;None
+ (#;Some (~ g!temp)))))))))
+
+(defsyntax #export (try expr)
+ (emit (@list (` (;_jvm_try (#;Right (~ expr))
+ (~ (' (_jvm_catch "java.lang.Exception" e
+ (#;Left (throwable->text e))))))))))
(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 (gensym "")
+ g!_ (gensym "")]
+ (emit (@list (` (let [(~ g!lock) (~ lock)
+ (~ g!_) (;_jvm_monitorenter (~ g!lock))
(~ g!body) (~ body)
- _ (_jvm_monitorexit (~ g!lock))]
- (~ g!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))))))
-
-(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.")))
+(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])])
+ (do Lux/Monad
+ [[vars var-types var-rebinds arg-classes] (prepare-args args)
+ #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))
+ return-type (class->type class)
+ [new-expr return-type] (if unsafe?
+ [(` (try (~ new-expr))) (` (Either Text (~ return-type)))]
+ [new-expr return-type])]]
+ (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type))
+ (lambda [[(~@ vars)]]
+ (let [(~@ var-rebinds)]
+ (~ new-expr)))))))))
- _
- (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-template [<name> <op> <use-self?>]
+ [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))]
+ [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])])
+ (do Lux/Monad
+ [[vars var-types var-rebinds arg-classes] (prepare-args args)
+ g!self (gensym "self")
+ #let [included-self (: (List AST)
+ (if <use-self?>
+ (@list g!self)
+ (@list)))
+ [body return-type] (gen-expected-output expected-output
+ (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)])))
+ [body return-type] (if unsafe?
+ [(` (try (~ body))) (` (Either Text (~ return-type)))]
+ [body return-type])]]
+ (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type))
+ (lambda [[(~@ vars)] (~@ included-self)]
+ (let [(~@ var-rebinds)]
+ (~ body)))))))
+ ))]
- _
- (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)]))))))
+ [invoke-virtual$ ;_jvm_invokevirtual true]
+ [invoke-interface$ ;_jvm_invokeinterface true]
+ [invoke-special$ ;_jvm_invokespecial true]
+ [invoke-static$ ;_jvm_invokestatic false]
+ )
generated by cgit v1.2.3 (git 2.25.1) at 2024-10-06 01:25:40 +0000