diff options
| -rw-r--r-- | source/lux.lux | 4 | ||||
| -rw-r--r-- | source/lux/host/jvm.lux | 70 | ||||
| -rw-r--r-- | source/lux/meta/syntax.lux | 22 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 14 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 93 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 8 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 37 |
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))))) |