aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/lux.clj16
-rw-r--r--luxc/src/lux/analyser/parser.clj418
-rw-r--r--luxc/src/lux/analyser/proc/jvm.clj91
-rw-r--r--luxc/src/lux/compiler/jvm.clj23
-rw-r--r--luxc/src/lux/compiler/jvm/lux.clj134
5 files changed, 334 insertions, 348 deletions
diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj
index 1ef5a4b09..df5cfb789 100644
--- a/luxc/src/lux/analyser/lux.clj
+++ b/luxc/src/lux/analyser/lux.clj
@@ -614,6 +614,14 @@
(fn [_]
(return* compiler* compiler*)))
+(defn try-async-compilation [path compile-module]
+ (|do [already-compiled? (&&module/exists? path)]
+ (if (not already-compiled?)
+ (compile-module path)
+ (|do [_compiler get-compiler]
+ (return (doto (promise)
+ (deliver (&/$Right _compiler))))))))
+
(defn analyse-module [analyse optimize eval! compile-module ?meta]
(|do [_ &/ensure-statement
=anns (&&/analyse-1 analyse &type/Code ?meta)
@@ -628,22 +636,16 @@
(&/save-module
(|do [_ (&/assert! (not (= current-module path))
(&/fail-with-loc (str "[Analyser Error] Module cannot import itself: " path)))
- already-compiled? (&&module/exists? path)
active? (&&module/active-module? path)
;; TODO: Enrich this error-message
;; to explicitly show the cyclic dependency.
_ (&/assert! (not active?)
(str "[Analyser Error] Cannot import a module that is mid-compilation { cyclic dependency }: " path " @ " current-module))
_ (&&module/add-import path)
- ?async (if (not already-compiled?)
- (compile-module path)
- (|do [_compiler get-compiler]
- (return (doto (promise)
- (deliver (&/$Right _compiler))))))
_ (if (= "" alias)
(return nil)
(&&module/alias current-module alias path))]
- (return ?async))))))
+ (try-async-compilation path compile-module))))))
_imports)
_compiler get-compiler
;; Some type-vars in the typing environment stay in
diff --git a/luxc/src/lux/analyser/parser.clj b/luxc/src/lux/analyser/parser.clj
index 90eb23164..c5cd84eab 100644
--- a/luxc/src/lux/analyser/parser.clj
+++ b/luxc/src/lux/analyser/parser.clj
@@ -12,6 +12,10 @@
;; [Parsers]
(def ^:private _space_ (&reader/read-text " "))
+(defn ^:private with-pre-space [action]
+ (|do [_ _space_]
+ action))
+
(defn ^:private repeat% [action]
(fn [state]
(|case (action state)
@@ -69,15 +73,15 @@
(def ^:private parse-type-param
(with-parens
(|do [=name parse-name
- _ _space_
- =bounds (spaced parse-gclass)]
+ =bounds (with-pre-space
+ (spaced parse-gclass))]
(return (&/T [=name =bounds])))))
(def ^:private parse-gclass-decl
(with-parens
(|do [=class-name parse-name
- _ _space_
- =params (spaced parse-type-param)]
+ =params (with-pre-space
+ (spaced parse-type-param))]
(return (&/T [=class-name =params])))))
(def ^:private parse-bound-kind
@@ -101,29 +105,29 @@
(with-parens
(|do [class-name parse-name
- _ _space_
- =params (spaced parse-gclass)]
+ =params (with-pre-space
+ (spaced parse-gclass))]
(return (&/$GenericClass class-name =params))))
(with-parens
(|do [_ (&reader/read-text "#Array")
- _ _space_
- =param parse-gclass]
+ =param (with-pre-space
+ parse-gclass)]
(return (&/$GenericArray =param))))
)))
(def ^:private parse-gclass-super
(with-parens
(|do [class-name parse-name
- _ _space_
- =params (spaced parse-gclass)]
+ =params (with-pre-space
+ (spaced parse-gclass))]
(return (&/T [class-name =params])))))
(def ^:private parse-ctor-arg
(with-brackets
(|do [=class parse-gclass
- _ _space_
- (&/$Cons =term (&/$Nil)) &parser/parse]
+ (&/$Cons =term (&/$Nil)) (with-pre-space
+ &parser/parse)]
(return (&/T [=class =term])))))
(def ^:private parse-ann-param
@@ -154,9 +158,9 @@
(def ^:private parse-ann
(with-parens
(|do [ann-name parse-name
- _ _space_
- =ann-params (with-braces
- (spaced parse-ann-param))]
+ =ann-params (with-pre-space
+ (with-braces
+ (spaced parse-ann-param)))]
(return {:name ann-name
:params =ann-params}))))
@@ -183,20 +187,20 @@
(def ^:private parse-method-decl
(with-parens
(|do [=method-name parse-name
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- parse-gvars)
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-gclass))
- _ _space_
- =output parse-gclass]
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ parse-gvars))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =output (with-pre-space
+ parse-gclass)]
(return (&/T [=method-name =anns =gvars =exceptions =inputs =output])))))
(def ^:private parse-privacy-modifier
@@ -237,156 +241,156 @@
(def ^:private parse-method-init-def
(|do [_ (&reader/read-text "init")
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
+ =privacy-modifier (with-pre-space
+ parse-privacy-modifier)
+ [_ (&lexer/$Bool =strict*)] (with-pre-space
+ &lexer/lex-bool)
:let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =ctor-args (with-brackets
- (spaced parse-ctor-arg))
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ (spaced parse-type-param)))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-arg-decl)))
+ =ctor-args (with-pre-space
+ (with-brackets
+ (spaced parse-ctor-arg)))
+ (&/$Cons =body (&/$Nil)) (with-pre-space
+ &parser/parse)]
(return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body])))))
(def ^:private parse-method-virtual-def
(|do [_ (&reader/read-text "virtual")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- [_ (&lexer/$Bool =final?*)] &lexer/lex-bool
+ =name (with-pre-space
+ parse-name)
+ =privacy-modifier (with-pre-space
+ parse-privacy-modifier)
+ [_ (&lexer/$Bool =final?*)] (with-pre-space
+ &lexer/lex-bool)
:let [=final? (Boolean/parseBoolean =final?*)]
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
+ [_ (&lexer/$Bool =strict*)] (with-pre-space
+ &lexer/lex-bool)
:let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ (spaced parse-type-param)))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-arg-decl)))
+ =output (with-pre-space
+ parse-gclass)
+ (&/$Cons =body (&/$Nil)) (with-pre-space
+ &parser/parse)]
(return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body])))))
(def ^:private parse-method-override-def
(|do [_ (&reader/read-text "override")
- _ _space_
- =class-decl parse-gclass-decl
- _ _space_
- =name parse-name
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
+ =class-decl (with-pre-space
+ parse-gclass-decl)
+ =name (with-pre-space
+ parse-name)
+ [_ (&lexer/$Bool =strict*)] (with-pre-space
+ &lexer/lex-bool)
:let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ (spaced parse-type-param)))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-arg-decl)))
+ =output (with-pre-space
+ parse-gclass)
+ (&/$Cons =body (&/$Nil)) (with-pre-space
+ &parser/parse)]
(return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body])))))
(def ^:private parse-method-static-def
(|do [_ (&reader/read-text "static")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
+ =name (with-pre-space
+ parse-name)
+ =privacy-modifier (with-pre-space
+ parse-privacy-modifier)
+ [_ (&lexer/$Bool =strict*)] (with-pre-space
+ &lexer/lex-bool)
:let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ (spaced parse-type-param)))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-arg-decl)))
+ =output (with-pre-space
+ parse-gclass)
+ (&/$Cons =body (&/$Nil)) (with-pre-space
+ &parser/parse)]
(return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body])))))
(def ^:private parse-method-abstract-def
(|do [_ (&reader/read-text "abstract")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass]
+ =name (with-pre-space
+ parse-name)
+ =privacy-modifier (with-pre-space
+ parse-privacy-modifier)
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ (spaced parse-type-param)))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-arg-decl)))
+ =output (with-pre-space
+ parse-gclass)]
(return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output])))))
(def ^:private parse-method-native-def
(|do [_ (&reader/read-text "native")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass]
+ =name (with-pre-space
+ parse-name)
+ =privacy-modifier (with-pre-space
+ parse-privacy-modifier)
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =gvars (with-pre-space
+ (with-brackets
+ (spaced parse-type-param)))
+ =exceptions (with-pre-space
+ (with-brackets
+ (spaced parse-gclass)))
+ =inputs (with-pre-space
+ (with-brackets
+ (spaced parse-arg-decl)))
+ =output (with-pre-space
+ parse-gclass)]
(return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output])))))
(def ^:private parse-method-def
@@ -402,73 +406,73 @@
(def ^:private parse-field
(with-parens
(&/try-all% (&/|list (|do [_ (&reader/read-text "constant")
- _ _space_
- =name parse-name
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =type parse-gclass
- _ _space_
- (&/$Cons =value (&/$Nil)) &parser/parse]
+ =name (with-pre-space
+ parse-name)
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =type (with-pre-space
+ parse-gclass)
+ (&/$Cons =value (&/$Nil)) (with-pre-space
+ &parser/parse)]
(return (&/$ConstantFieldSyntax =name =anns =type =value)))
(|do [_ (&reader/read-text "variable")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- =state-modifier parse-state-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =type parse-gclass]
+ =name (with-pre-space
+ parse-name)
+ =privacy-modifier (with-pre-space
+ parse-privacy-modifier)
+ =state-modifier (with-pre-space
+ parse-state-modifier)
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =type (with-pre-space
+ parse-gclass)]
(return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type)))
))))
(def parse-interface-def
(|do [=gclass-decl parse-gclass-decl
- _ _space_
- =supers (with-brackets
- (spaced parse-gclass-super))
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =methods (spaced parse-method-decl)]
+ =supers (with-pre-space
+ (with-brackets
+ (spaced parse-gclass-super)))
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =methods (with-pre-space
+ (spaced parse-method-decl))]
(return (&/T [=gclass-decl =supers =anns =methods]))))
(def parse-class-def
(|do [=gclass-decl parse-gclass-decl
- _ _space_
- =super-class parse-gclass-super
- _ _space_
- =interfaces (with-brackets
- (spaced parse-gclass-super))
- _ _space_
- =inheritance-modifier parse-inheritance-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =fields (with-brackets
- (spaced parse-field))
- _ _space_
- =methods (with-brackets
- (spaced parse-method-def))]
+ =super-class (with-pre-space
+ parse-gclass-super)
+ =interfaces (with-pre-space
+ (with-brackets
+ (spaced parse-gclass-super)))
+ =inheritance-modifier (with-pre-space
+ parse-inheritance-modifier)
+ =anns (with-pre-space
+ (with-brackets
+ (spaced parse-ann)))
+ =fields (with-pre-space
+ (with-brackets
+ (spaced parse-field)))
+ =methods (with-pre-space
+ (with-brackets
+ (spaced parse-method-def)))]
(return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods]))))
(def parse-anon-class-def
(|do [=super-class parse-gclass-super
- _ _space_
- =interfaces (with-brackets
- (spaced parse-gclass-super))
- _ _space_
- =ctor-args (with-brackets
- (spaced parse-ctor-arg))
- _ _space_
- =methods (with-brackets
- (spaced parse-method-def))]
+ =interfaces (with-pre-space
+ (with-brackets
+ (spaced parse-gclass-super)))
+ =ctor-args (with-pre-space
+ (with-brackets
+ (spaced parse-ctor-arg)))
+ =methods (with-pre-space
+ (with-brackets
+ (spaced parse-method-def)))]
(return (&/T [=super-class =interfaces =ctor-args =methods]))))
diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj
index 69d734177..8d926f437 100644
--- a/luxc/src/lux/analyser/proc/jvm.clj
+++ b/luxc/src/lux/analyser/proc/jvm.clj
@@ -717,32 +717,39 @@
(return (&/T [==gret ==args])))))
))
+(defn ^:private up-cast [class parent-gvars class-loader !class! object-type]
+ (|do [[sub-class sub-params] (ensure-object object-type)
+ (&/$Primitive super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class)
+ !class!
+ sub-class)
+ sub-params)]
+ (return (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m))
+ (&/|table)
+ parent-gvars
+ super-params*))))
+
+(defn ^:private check-method! [only-interface? class method]
+ (|do [!class! (&/de-alias-class class)
+ class-loader &/loader
+ _ (try (assert! (let [=class (Class/forName !class! true class-loader)]
+ (= only-interface? (.isInterface =class)))
+ (if only-interface?
+ (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.")
+ (str "[Analyser Error] Can only invoke method \"" method "\"" " on class.")))
+ (catch Exception e
+ (&/fail-with-loc (str "[Analyser Error] Unknown class: " class))))]
+ (return (&/T [!class! class-loader]))))
+
(let [dummy-type-param (&/$Primitive "java.lang.Object" &/$Nil)]
(do-template [<name> <tag> <only-interface?>]
(defn <name> [analyse exo-type class method classes ?values]
- (|do [!class! (&/de-alias-class class)
- :let [(&/$Cons object args) ?values]
- class-loader &/loader
- _ (try (assert! (let [=class (Class/forName !class! true class-loader)]
- (= <only-interface?> (.isInterface =class)))
- (if <only-interface?>
- (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.")
- (str "[Analyser Error] Can only invoke method \"" method "\"" " on class.")))
- (catch Exception e
- (&/fail-with-loc (str "[Analyser Error] Unknown class: " class))))
+ (|do [:let [(&/$Cons object args) ?values]
+ [!class! class-loader] (check-method! <only-interface?> class method)
[gret exceptions parent-gvars gvars gargs] (if (= "<init>" method)
(return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil]))
(&host/lookup-virtual-method class-loader !class! method classes))
=object (&&/analyse-1+ analyse object)
- [sub-class sub-params] (ensure-object (&&/expr-type* =object))
- (&/$Primitive super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class)
- !class!
- sub-class)
- sub-params)
- :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m))
- (&/|table)
- parent-gvars
- super-params*)]
+ gtype-env (up-cast class parent-gvars class-loader !class! (&&/expr-type* =object))
[output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
@@ -849,6 +856,17 @@
[name [_ (&&/$captured _ _ source)]]
source))
+(defn ^:private analyse-methods [analyse class-decl all-supers methods]
+ (|do [=methods (&/map% (partial analyse-method analyse class-decl &/$Nil all-supers) methods)
+ _ (check-method-completion all-supers =methods)
+ =captured &&env/captured-vars]
+ (return (&/T [=methods =captured]))))
+
+(defn ^:private get-names []
+ (|do [module &/get-module-name
+ scope &/get-scope-name]
+ (return (&/T [module scope]))))
+
(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM
false
&/$Nil
@@ -861,8 +879,7 @@
captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)]
(defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods]
(&/with-closure
- (|do [module &/get-module-name
- scope &/get-scope-name
+ (|do [[module scope] (get-names)
:let [name (->> scope &/|reverse &/|tail &host/location)
class-decl (&/T [name &/$Nil])
anon-class (str (string/replace module "/" ".") "." name)
@@ -875,26 +892,22 @@
_ (->> methods
(&/$Cons default-<init>)
(&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil))
- :let [all-supers (&/$Cons super-class interfaces)
- class-env &/$Nil]
- =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods)
- _ (check-method-completion all-supers =methods)
- =captured &&env/captured-vars
- :let [=fields (&/|map (fn [^objects idx+capt]
- (|let [[idx _] idx+capt]
- (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx)
- &/$PublicPM
- &/$FinalSM
- &/$Nil
- captured-slot-type)))
- (&/enumerate =captured))]
- :let [sources (&/|map captured-source =captured)]
- _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args))
+ [=methods =captured] (let [all-supers (&/$Cons super-class interfaces)]
+ (analyse-methods analyse class-decl all-supers methods))
+ _ (let [=fields (&/|map (fn [^objects idx+capt]
+ (|let [[idx _] idx+capt]
+ (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx)
+ &/$PublicPM
+ &/$FinalSM
+ &/$Nil
+ captured-slot-type)))
+ (&/enumerate =captured))]
+ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)))
_ &/pop-dummy-name
_cursor &/cursor]
- (return (&/|list (&&/|meta anon-class-type _cursor
- (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class)))
- )))
+ (let [sources (&/|map captured-source =captured)]
+ (return (&/|list (&&/|meta anon-class-type _cursor
+ (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class)))))))
))))
(defn analyse-host [analyse exo-type compilers proc ?values]
diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj
index ff728ae81..68b0e15b7 100644
--- a/luxc/src/lux/compiler/jvm.clj
+++ b/luxc/src/lux/compiler/jvm.clj
@@ -167,6 +167,17 @@
(partial &&proc-host/compile-jvm-class compile-expression*)
&&proc-host/compile-jvm-interface])))
+(defn ^:private activate-module! [name file-hash]
+ (|do [_ (&&cache/delete name)
+ _ (&a-module/create-module name file-hash)]
+ (&a-module/flag-active-module name)))
+
+(defn ^:private save-module! [name file-hash class-bytes]
+ (|do [_ (&a-module/flag-compiled-module name)
+ _ (&&/save-class! &/module-class-name class-bytes)
+ module-descriptor (&&core/generate-module-descriptor file-hash)]
+ (&&core/write-module-descriptor! name module-descriptor)))
+
(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)
+datum-sig+ "Ljava/lang/Object;"]
(defn compile-module [source-dirs name]
@@ -178,9 +189,7 @@
(|do [module-exists? (&a-module/exists? name)]
(if module-exists?
(&/fail-with-loc (str "[Compiler Error] Cannot re-define a module: " name))
- (|do [_ (&&cache/delete name)
- _ (&a-module/create-module name file-hash)
- _ (&a-module/flag-active-module name)
+ (|do [_ (activate-module! name file-hash)
:let [module-class-name (str (&host/->module-class name) "/_")
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
@@ -198,17 +207,13 @@
(&/set$ &/$source (&reader/from name file-content) state))
(&/$Right ?state _)
(&/run-state (|do [:let [_ (.visitEnd =class)]
- _ (&a-module/flag-compiled-module name)
- _ (&&/save-class! &/module-class-name (.toByteArray =class))
- module-descriptor (&&core/generate-module-descriptor file-hash)
- _ (&&core/write-module-descriptor! name module-descriptor)]
+ _ (save-module! name file-hash (.toByteArray =class))]
(return file-hash))
?state)
(&/$Left ?message)
(&/fail* ?message))))))))
- )
- ))
+ )))
(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
(class (byte-array []))
diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj
index d98c7537b..958db64ec 100644
--- a/luxc/src/lux/compiler/jvm/lux.clj
+++ b/luxc/src/lux/compiler/jvm/lux.clj
@@ -248,6 +248,52 @@
(str base "\n\n" "Caused by: " (throwable->text cause))
base)))
+(defn ^:private install-def! [class-loader current-class module-name ?name ?body ?meta]
+ (|do [_ (return nil)
+ :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
+ def-type (&a/expr-type* ?body)
+ is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
+ (&/$Some [_ (&/$Bool true)])
+ true
+
+ _
+ false)
+ def-meta ?meta]
+ def-value (try (return (-> def-class (.getField &/value-field) (.get nil)))
+ (catch Throwable t
+ (&/assert! false
+ (str "Error during value initialization:\n"
+ (throwable->text t)))))
+ _ (&/without-repl-closure
+ (&a-module/define module-name ?name def-type def-meta def-value))]
+ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
+ [true (&/$Some [_ (&/$Tuple tags*)])]
+ (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
+ (&/$Some _)
+ true
+
+ _
+ false)]
+ tags (&/map% (fn [tag*]
+ (|case tag*
+ [_ (&/$Text tag)]
+ (return tag)
+
+ _
+ (&/fail-with-loc "[Compiler Error] Incorrect format for tags.")))
+ tags*)
+ _ (&a-module/declare-tags module-name tags was-exported? def-value)]
+ (return nil))
+
+ [false (&/$Some _)]
+ (&/fail-with-loc "[Compiler Error] Cannot define tags for non-type.")
+
+ [true (&/$Some _)]
+ (&/fail-with-loc "[Compiler Error] Incorrect format for tags.")
+
+ [_ (&/$None)]
+ (return nil))))
+
(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)]
(defn compile-def [compile ?name ?body ?meta]
@@ -300,49 +346,7 @@
(return nil)))
:let [_ (.visitEnd =class)]
_ (&&/save-class! def-name (.toByteArray =class))
- :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
- def-type (&a/expr-type* ?body)
- is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
- (&/$Some [_ (&/$Bool true)])
- true
-
- _
- false)
- def-meta ?meta]
- def-value (try (return (-> def-class (.getField &/value-field) (.get nil)))
- (catch Throwable t
- (&/assert! false
- (str "Error during value initialization:\n"
- (throwable->text t)))))
- _ (&/without-repl-closure
- (&a-module/define module-name ?name def-type def-meta def-value))
- _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
- [true (&/$Some [_ (&/$Tuple tags*)])]
- (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
- (&/$Some _)
- true
-
- _
- false)]
- tags (&/map% (fn [tag*]
- (|case tag*
- [_ (&/$Text tag)]
- (return tag)
-
- _
- (&/fail-with-loc "[Compiler Error] Incorrect format for tags.")))
- tags*)
- _ (&a-module/declare-tags module-name tags was-exported? def-value)]
- (return nil))
-
- [false (&/$Some _)]
- (&/fail-with-loc "[Compiler Error] Cannot define tags for non-type.")
-
- [true (&/$Some _)]
- (&/fail-with-loc "[Compiler Error] Incorrect format for tags.")
-
- [_ (&/$None)]
- (return nil))
+ _ (install-def! class-loader current-class module-name ?name ?body ?meta)
:let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]]
(return nil)))
@@ -369,49 +373,7 @@
(return nil)))
:let [_ (.visitEnd =class)]
_ (&&/save-class! def-name (.toByteArray =class))
- :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
- def-type (&a/expr-type* ?body)
- is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
- (&/$Some [_ (&/$Bool true)])
- true
-
- _
- false)
- def-meta ?meta]
- def-value (try (return (-> def-class (.getField &/value-field) (.get nil)))
- (catch Throwable t
- (&/assert! false
- (str "Error during value initialization:\n"
- (throwable->text t)))))
- _ (&/without-repl-closure
- (&a-module/define module-name ?name def-type def-meta def-value))
- _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
- [true (&/$Some [_ (&/$Tuple tags*)])]
- (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
- (&/$Some _)
- true
-
- _
- false)]
- tags (&/map% (fn [tag*]
- (|case tag*
- [_ (&/$Text tag)]
- (return tag)
-
- _
- (&/fail-with-loc "[Compiler Error] Incorrect format for tags.")))
- tags*)
- _ (&a-module/declare-tags module-name tags was-exported? def-value)]
- (return nil))
-
- [false (&/$Some _)]
- (&/fail-with-loc "[Compiler Error] Cannot define tags for non-type.")
-
- [true (&/$Some _)]
- (&/fail-with-loc "[Compiler Error] Incorrect format for tags.")
-
- [_ (&/$None)]
- (return nil))
+ _ (install-def! class-loader current-class module-name ?name ?body ?meta)
:let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]]
(return nil)))
))))