aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux4
-rw-r--r--source/lux/host/jvm.lux70
-rw-r--r--source/lux/meta/syntax.lux22
-rw-r--r--src/lux/analyser.clj14
-rw-r--r--src/lux/analyser/host.clj93
-rw-r--r--src/lux/compiler.clj8
-rw-r--r--src/lux/compiler/host.clj37
7 files changed, 189 insertions, 59 deletions
diff --git a/source/lux.lux b/source/lux.lux
index fbdd71904..dddf5c80d 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -4,8 +4,8 @@
## You can obtain one at http://mozilla.org/MPL/2.0/.
## First things first, must define functions
-(_jvm_interface "Function" []
- ("apply" ["public" "abstract"] [] ["java.lang.Object"] "java.lang.Object"))
+(_jvm_interface "Function" [] []
+ ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object"))
## Basic types
(_lux_def Bool (10 ["lux" "Bool"]
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux
index 4892ba333..bbb396874 100644
--- a/source/lux/host/jvm.lux
+++ b/source/lux/host/jvm.lux
@@ -33,9 +33,17 @@
(deftype Modifier Text)
(deftype JvmType Text)
+(deftype AnnotationParam
+ (, Text AST))
+
+(deftype Annotation
+ (& #ann-name Text
+ #ann-params (List AnnotationParam)))
+
(deftype MemberDecl
- (& #member-modifiers (List Modifier)
- #member-name Text))
+ (& #member-name Text
+ #member-modifiers (List Modifier)
+ #member-anns (List Annotation)))
(deftype FieldDecl
JvmType)
@@ -86,9 +94,34 @@
(wrap [vars var-types (list:join var-rebinds) arg-classes])))
## Parsers
+(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)
- (&^ (*^ local-tag^) local-symbol^))
+ (do Parser/Monad
+ [modifiers (*^ local-tag^)
+ name local-symbol^
+ anns annotations^]
+ (wrap [name modifiers anns])))
(def throws-decl'^
(Parser (List JvmType))
@@ -152,18 +185,29 @@
(wrap [ex? opt? return])))
## Generators
-(def (gen-method-decl [[modifiers name] [inputs output exs]])
+(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 [[modifiers name] class])
+(def (gen-field-decl [[name modifiers anns] class])
(-> (, MemberDecl FieldDecl) AST)
(` ((~ (text$ name))
[(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
(~ (text$ class))
)))
@@ -171,10 +215,11 @@
(-> ArgDecl AST)
(form$ (@list (symbol$ ["" name]) (text$ type))))
-(def (gen-method-def [[modifiers name] [inputs output body exs]])
+(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))
@@ -217,18 +262,23 @@
(|> t get-stack-trace stack-trace->text)))
## [Syntax]
-(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)])
- (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
- (~@ (map gen-method-decl members)))))))
-
(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))
diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux
index d9f3c6dc3..641dfba0d 100644
--- a/source/lux/meta/syntax.lux
+++ b/source/lux/meta/syntax.lux
@@ -12,7 +12,7 @@
(data (bool #as b)
(char #as c)
(text #as t #open ("text:" Text/Monoid Text/Eq))
- (list #refer #all #open ("" List/Fold))
+ (list #refer #all #open ("" List/Functor List/Fold))
(number (int #open ("i" Int/Ord))
(real #open ("r" Real/Eq))))))
@@ -28,6 +28,10 @@
#;Nil #;Nil
(#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs'))))
+(def (pair->tuple [left right])
+ (-> (, AST AST) AST)
+ (tuple$ (@list left right)))
+
## [Types]
(deftype #export (Parser a)
(-> (List AST) (Maybe (, (List AST) a))))
@@ -163,8 +167,8 @@
(All [a]
(-> (Parser a) (Parser a)))
(case tokens
- (#;Cons [[_ (<tag> form)] tokens'])
- (case (p form)
+ (#;Cons [[_ (<tag> members)] tokens'])
+ (case (p members)
(#;Some [#;Nil x]) (#;Some [tokens' x])
_ #;None)
@@ -175,6 +179,18 @@
[tuple^ #;TupleS]
)
+(def #export (record^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (case tokens
+ (#;Cons [[_ (#;RecordS pairs)] tokens'])
+ (case (p (map pair->tuple pairs))
+ (#;Some [#;Nil x]) (#;Some [tokens' x])
+ _ #;None)
+
+ _
+ #;None))
+
(def #export (?^ p tokens)
(All [a]
(-> (Parser a) (Parser (Maybe a))))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 190b34b03..5659a066e 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -160,18 +160,20 @@
(&/$Cons [_ (&/$TextS ?name)]
(&/$Cons [_ (&/$TextS ?super-class)]
(&/$Cons [_ (&/$TupleS ?interfaces)]
- (&/$Cons [_ (&/$TupleS ?fields)]
- (&/$Cons [_ (&/$TupleS ?methods)]
- (&/$Nil))))))))
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ (&/$Cons [_ (&/$TupleS ?fields)]
+ (&/$Cons [_ (&/$TupleS ?methods)]
+ (&/$Nil)))))))))
(|do [=interfaces (&/map% extract-text ?interfaces)]
- (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?fields ?methods))
+ (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?anns ?fields ?methods))
(&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")]
(&/$Cons [_ (&/$TextS ?name)]
(&/$Cons [_ (&/$TupleS ?supers)]
- ?methods))))
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ ?methods)))))
(|do [=supers (&/map% extract-text ?supers)]
- (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods))
+ (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?anns ?methods))
(&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")]
(&/$Cons [_ (&/$TextS ?super-class)]
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 53ab1de5b..5208b2883 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -411,15 +411,45 @@
:concurrency nil}
modifiers))
+(let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))]
+ (defn ^:private extract-ann-param [param]
+ (|case param
+ [[_ (&/$TextS param-name)] param-value]
+ (|case param-value
+ [_ (&/$BoolS param-value*)] (return (&/T param-name (boolean param-value*)))
+ [_ (&/$IntS param-value*)] (return (&/T param-name (int param-value*)))
+ [_ (&/$RealS param-value*)] (return (&/T param-name (float param-value*)))
+ [_ (&/$CharS param-value*)] (return (&/T param-name (char param-value*)))
+ [_ (&/$TextS param-value*)] (return (&/T param-name param-value*))
+
+ _
+ failure)
+
+ _
+ failure)))
+
+(defn ^:private analyse-ann [ann]
+ (|case ann
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS ann-name)] (&/$Cons [_ (&/$RecordS ann-params)] (&/$Nil))))]
+ (|do [=ann-params (&/map% extract-ann-param ann-params)]
+ (return {:name ann-name
+ :params ann-params}))
+
+ _
+ (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ann)))))
+
(defn ^:private analyse-field [field]
(|case field
[_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)]
(&/$Cons [_ (&/$TupleS ?field-modifiers)]
- (&/$Cons [_ (&/$TextS ?field-type)]
- (&/$Nil)))))]
- (|do [=field-modifiers (analyse-modifiers ?field-modifiers)]
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ (&/$Cons [_ (&/$TextS ?field-type)]
+ (&/$Nil))))))]
+ (|do [=field-modifiers (analyse-modifiers ?field-modifiers)
+ =anns (&/map% analyse-ann ?anns)]
(return {:name ?field-name
:modifiers =field-modifiers
+ :anns =anns
:type ?field-type}))
_
@@ -429,11 +459,12 @@
(|case method
[_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
(&/$Cons [_ (&/$TupleS method-modifiers)]
- (&/$Cons [_ (&/$TupleS method-exs)]
- (&/$Cons [_ (&/$TupleS method-inputs)]
- (&/$Cons [_ (&/$TextS method-output)]
- (&/$Cons method-body
- (&/$Nil))))))))]
+ (&/$Cons [_ (&/$TupleS method-anns)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS method-inputs)]
+ (&/$Cons [_ (&/$TextS method-output)]
+ (&/$Cons method-body
+ (&/$Nil)))))))))]
(|do [=method-modifiers (analyse-modifiers method-modifiers)
=method-exs (&/map% extract-text method-exs)
=method-inputs (&/map% (fn [minput]
@@ -448,23 +479,26 @@
method-inputs)]
(return {:name method-name
:modifiers =method-modifiers
+ :anns (&/|list)
:exceptions =method-exs
:inputs (&/|map &/|second =method-inputs)
:output method-output}))
_
- (fail "[Analyser Error] Wrong syntax for method.")))
+ (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method)))))
(defn ^:private analyse-method [analyse owner-class method]
(|case method
[_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
(&/$Cons [_ (&/$TupleS method-modifiers)]
- (&/$Cons [_ (&/$TupleS method-exs)]
- (&/$Cons [_ (&/$TupleS method-inputs)]
- (&/$Cons [_ (&/$TextS method-output)]
- (&/$Cons method-body
- (&/$Nil))))))))]
+ (&/$Cons [_ (&/$TupleS method-anns)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS method-inputs)]
+ (&/$Cons [_ (&/$TextS method-output)]
+ (&/$Cons method-body
+ (&/$Nil)))))))))]
(|do [=method-modifiers (analyse-modifiers method-modifiers)
+ =anns (&/map% analyse-ann method-anns)
=method-exs (&/map% extract-text method-exs)
=method-inputs (&/map% (fn [minput]
(|case minput
@@ -487,27 +521,31 @@
=method-inputs)))]
(return {:name method-name
:modifiers =method-modifiers
+ :anns =anns
:exceptions =method-exs
:inputs (&/|map &/|second =method-inputs)
:output method-output
:body =method-body}))
_
- (fail "[Analyser Error] Wrong syntax for method.")))
+ (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method)))))
(defn ^:private analyse-method-decl [method]
(|case method
[_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
(&/$Cons [_ (&/$TupleS modifiers)]
- (&/$Cons [_ (&/$TupleS method-exs)]
- (&/$Cons [_ (&/$TupleS inputs)]
- (&/$Cons [_ (&/$TextS output)]
- (&/$Nil)))))))]
- (|do [=inputs (&/map% extract-text inputs)
- =modifiers (analyse-modifiers modifiers)
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS inputs)]
+ (&/$Cons [_ (&/$TextS output)]
+ (&/$Nil))))))))]
+ (|do [=modifiers (analyse-modifiers modifiers)
+ =anns (&/map% analyse-ann ?anns)
+ =inputs (&/map% extract-text inputs)
=method-exs (&/map% extract-text method-exs)]
(return {:name method-name
:modifiers =modifiers
+ :anns =anns
:exceptions =method-exs
:inputs =inputs
:output output}))
@@ -544,11 +582,12 @@
(return nil)
(fail (str "[Analyser Error] Missing method: " missing-method)))))
-(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods]
+(defn analyse-jvm-class [analyse compile-token name super-class interfaces anns fields methods]
(&/with-closure
(|do [module &/get-module-name
:let [full-name (str module "." name)]
;; :let [_ (prn 'analyse-jvm-class/_0)]
+ =anns (&/map% analyse-ann anns)
=fields (&/map% analyse-field fields)
;; :let [_ (prn 'analyse-jvm-class/_1)]
=method-descs (&/map% dummy-method-desc methods)
@@ -557,14 +596,15 @@
;; :let [_ (prn 'analyse-jvm-class/_2)]
_ (check-method-completion (&/Cons$ super-class interfaces) =methods)
;; :let [_ (prn 'analyse-jvm-class/_3)]
- _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil)))
+ _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =anns =fields =methods nil)))
:let [_ (println 'DEF (str module "." name))]]
(return &/Nil$))))
-(defn analyse-jvm-interface [analyse compile-token name supers methods]
+(defn analyse-jvm-interface [analyse compile-token name supers anns methods]
(|do [module &/get-module-name
+ =anns (&/map% analyse-ann anns)
=methods (&/map% analyse-method-decl methods)
- _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))
+ _ (compile-token (&/V &&/$jvm-interface (&/T name supers =anns =methods)))
:let [_ (println 'DEF (str module "." name))]]
(return &/Nil$)))
@@ -598,6 +638,7 @@
:let [=fields (&/|map (fn [idx+capt]
{:name (str &c!base/closure-prefix (aget idx+capt 0))
:modifiers captured-slot-modifier
+ :anns (&/|list)
:type captured-slot-type})
(&/enumerate =captured))
;; _ (prn '=methods (&/adt->text (&/|map :body =methods)))
@@ -606,7 +647,7 @@
:let [sources (&/|map captured-source =captured)]
;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)]
;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type))
- _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured)))
+ _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured)))
:let [_ (println 'DEF anon-class)]
_cursor &/cursor]
(return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index d89684bcc..90b8bcc05 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -430,11 +430,11 @@
(&a/$jvm-program ?body)
(&&host/compile-jvm-program compile-expression ?body)
- (&a/$jvm-interface ?name ?supers ?methods)
- (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods)
+ (&a/$jvm-interface ?name ?supers ?anns ?methods)
+ (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods)
- (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env)
- (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env)
+ (&a/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env)
+ (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env)
_
(compile-expression syntax)))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 95d63b0fb..2322b0e32 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -410,6 +410,25 @@
(&&/wrap-boolean))]]
(return nil)))
+(defn ^:private compile-annotation [writer ann]
+ (doto (.visitAnnotation writer (&host/->class (:name ann)) true)
+ (-> (.visit param-name param-value)
+ (->> (|let [[param-name param-value] param])
+ (doseq [param (&/->seq (:params ann))])))
+ (.visitEnd))
+ nil)
+
+(defn ^:private compile-field [writer field]
+ (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field)
+ (&host/->type-signature (:type field)) nil nil)]
+ (&/|map (partial compile-annotation =field) (:anns field))
+ (.visitEnd =field)
+ nil)
+ ;; (doto (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field)
+ ;; (&host/->type-signature (:type field)) nil nil)
+ ;; (.visitEnd))
+ )
+
(defn ^:private compile-method-return [writer output]
(case output
"void" (.visitInsn writer Opcodes/RETURN)
@@ -453,7 +472,8 @@
nil
(->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))
(|do [^MethodVisitor =method &/get-writer
- :let [_ (.visitCode =method)]
+ :let [_ (&/|map (partial compile-annotation =method) (:anns method))
+ _ (.visitCode =method)]
_ (compile (:body method))
:let [_ (doto =method
(compile-method-return (:output method))
@@ -464,7 +484,9 @@
(defn ^:private compile-method-decl [class-writer method]
(|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")"
(&host/->type-signature (:output method)))]
- (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))))
+ (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))]
+ (&/|map (partial compile-annotation =method) (:anns method))
+ nil)))
(let [clo-field-sig (&host/->type-signature "java.lang.Object")
<init>-return "V"]
@@ -489,7 +511,7 @@
(.visitEnd)))
)
-(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env]
+(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env]
(|do [;; :let [_ (prn 'compile-jvm-class/_0)]
module &/get-module-name
;; :let [_ (prn 'compile-jvm-class/_1)]
@@ -500,10 +522,8 @@
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))
(.visitSource file-name nil))
- _ (&/|map (fn [field]
- (doto (.visitField =class (&host/modifiers->int (:modifiers field)) (:name field)
- (&host/->type-signature (:type field)) nil nil)
- (.visitEnd)))
+ _ (&/|map (partial compile-annotation =class) ?anns)
+ _ (&/|map (partial compile-field =class)
?fields)]
;; :let [_ (prn 'compile-jvm-class/_2)]
_ (&/map% (partial compile-method compile =class) ?methods)
@@ -514,7 +534,7 @@
]
(&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
-(defn compile-jvm-interface [compile ?name ?supers ?methods]
+(defn compile-jvm-interface [compile ?name ?supers ?anns ?methods]
;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str))
(|do [module &/get-module-name
[file-name _ _] &/cursor]
@@ -522,6 +542,7 @@
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
(str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))
(.visitSource file-name nil))
+ _ (&/|map (partial compile-annotation =interface) ?anns)
_ (do (&/|map (partial compile-method-decl =interface) ?methods)
(.visitEnd =interface))]
(&&/save-class! ?name (.toByteArray =interface)))))