diff options
| -rw-r--r-- | luxc/src/lux/analyser/lux.clj | 16 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/parser.clj | 418 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/proc/jvm.clj | 91 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm.clj | 23 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm/lux.clj | 134 |
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))) )))) |