diff options
| -rw-r--r-- | src/lux.clj | 4 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 29 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 265 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 5 | ||||
| -rw-r--r-- | src/lux/analyser/parser.clj | 79 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 3 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 7 | ||||
| -rw-r--r-- | src/lux/compiler/cache.clj | 3 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 191 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 5 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 3 | ||||
| -rw-r--r-- | src/lux/host.clj | 102 | ||||
| -rw-r--r-- | src/lux/host/generics.clj | 76 | ||||
| -rw-r--r-- | src/lux/type.clj | 5 |
15 files changed, 447 insertions, 332 deletions
diff --git a/src/lux.clj b/src/lux.clj index c5d192879..15ba16e5c 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -14,9 +14,7 @@ (defn -main [& args] (|case (&/->list args) (&/$Cons "compile" (&/$Cons program-module (&/$Nil))) - (if program-module - (time (&compiler/compile-program program-module)) - (println "Please provide a module name to compile.")) + (time (&compiler/compile-program program-module)) _ (println "Can't understand command."))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0f1f2ae37..ff8863003 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -152,15 +152,20 @@ (|case token ;; Classes & interfaces (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons ?class-decl + (&/$Cons ?super-class (&/$Cons [_ (&/$TupleS ?interfaces)] (&/$Cons [_ (&/$TupleS ?anns)] (&/$Cons [_ (&/$TupleS ?fields)] (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil))))))))) - (|do [=interfaces (&/map% &&a-parser/parse-text ?interfaces)] - (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?anns ?fields ?methods)) + (|do [=gclass-decl (&&a-parser/parse-gclass-decl ?class-decl) + =super-class (&&a-parser/parse-gclass-super ?super-class) + =interfaces (&/map% &&a-parser/parse-gclass-super ?interfaces) + =anns (&/map% &&a-parser/parse-ann ?anns) + =fields (&/map% &&a-parser/parse-field ?fields) + =methods (&/map% &&a-parser/parse-method-def ?methods)] + (&&host/analyse-jvm-class analyse compile-token =gclass-decl =super-class =interfaces =anns =fields =methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] (&/$Cons ?class-decl @@ -168,18 +173,22 @@ (&/$Cons [_ (&/$TupleS ?anns)] ?methods))))) (|do [=gclass-decl (&&a-parser/parse-gclass-decl ?class-decl) - =supers (&/map% &&a-parser/parse-gclass-super ?supers)] - (&&host/analyse-jvm-interface analyse compile-token =gclass-decl =supers ?anns ?methods)) + =supers (&/map% &&a-parser/parse-gclass-super ?supers) + =anns (&/map% &&a-parser/parse-ann ?anns) + =methods (&/map% &&a-parser/parse-method-decl ?methods)] + (&&host/analyse-jvm-interface analyse compile-token =gclass-decl =supers =anns =methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] - (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons ?super-class (&/$Cons [_ (&/$TupleS ?interfaces)] (&/$Cons [_ (&/$TupleS ?ctor-args)] (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil))))))) - (|do [=interfaces (&/map% &&a-parser/parse-text ?interfaces) - =ctor-args (&/map% &&a-parser/parse-ctor-arg ?ctor-args)] - (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces =ctor-args ?methods)) + (|do [=super-class (&&a-parser/parse-gclass-super ?super-class) + =interfaces (&/map% &&a-parser/parse-gclass-super ?interfaces) + =ctor-args (&/map% &&a-parser/parse-ctor-arg ?ctor-args) + =methods (&/map% &&a-parser/parse-method-def ?methods)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type =super-class =interfaces =ctor-args =methods)) ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index b51dc21e7..b4d862be2 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -451,149 +451,143 @@ (&/V &&/$jvm-arraylength =array) ))))) -(defn ^:private analyse-field [field] - (|case field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Cons [_ (&/$TupleS ?anns)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Nil))))))] - (|do [=field-modifiers (&&a-parser/parse-modifiers ?field-modifiers) - =anns (&/map% &&a-parser/parse-ann ?anns)] - (return {:name ?field-name - :modifiers =field-modifiers - :anns =anns - :type ?field-type})) +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" - _ - (fail "[Analyser Error] Wrong syntax for field."))) - -(defn ^:private dummy-method-desc [method] - (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-anns)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil)))))))))] - (|do [=method-modifiers (&&a-parser/parse-modifiers method-modifiers) - =method-exs (&/map% &&a-parser/parse-text method-exs) - =method-inputs (&/map% (fn [minput] - (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] - (&/$Cons [_ (&/$TextS input-type)] - (&/$Nil))))] - (return (&/T input-name input-type)) - - _ - (fail "[Analyser Error] Wrong syntax for method input."))) - method-inputs)] - (return {:name method-name - :modifiers =method-modifiers - :anns (&/|list) - :exceptions =method-exs - :inputs (&/|map &/|second =method-inputs) - :output method-output})) - - _ - (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-anns)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil)))))))))] - (|do [=method-modifiers (&&a-parser/parse-modifiers method-modifiers) - =anns (&/map% &&a-parser/parse-ann method-anns) - =method-exs (&/map% &&a-parser/parse-text method-exs) - =method-inputs (&/map% (fn [minput] - (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] - (&/$Cons [_ (&/$TextS input-type)] - (&/$Nil))))] - (return (&/T input-name input-type)) - - _ - (fail "[Analyser Error] Wrong syntax for method input."))) - method-inputs) - =method-body (&/fold (fn [body* input*] - (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) - body*))) - (if (= "void" method-output) - (&&/analyse-1+ analyse method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) - (&/|reverse (&/Cons$ (&/T &&/jvm-this owner-class) - =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})) + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [gclass] + "(-> GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (return (&type/Data$ "java.lang.Object" &/Nil$)) - _ - (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) + (&/$GenericClass name params) + (case name + "boolean" (return (&type/Data$ "java.lang.Boolean" (&/|list))) + "byte" (return (&type/Data$ "java.lang.Byte" (&/|list))) + "short" (return (&type/Data$ "java.lang.Short" (&/|list))) + "int" (return (&type/Data$ "java.lang.Integer" (&/|list))) + "long" (return (&type/Data$ "java.lang.Long" (&/|list))) + "float" (return (&type/Data$ "java.lang.Float" (&/|list))) + "double" (return (&type/Data$ "java.lang.Double" (&/|list))) + "char" (return (&type/Data$ "java.lang.Character" (&/|list))) + "void" (return &type/Unit) + ;; else + (|do [=params (&/map% generic-class->type params)] + (return (&type/Data$ name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type param)] + (return (&type/Data$ &host-type/array-data-tag (&/|list =param)))) + )) + +(defn ^:private analyse-method [analyse class-decl method] + (|do [:let [[?cname ?cparams] class-decl + class-type (&type/Data$ ?cname &/Nil$) + [?decl ?body] method + [_ _ _ _ _ ?inputs ?output] ?decl] + output-type (generic-class->type ?output) + =body (&/fold (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type itype*)] + (&&env/with-local iname itype + body*))) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type) + ?inputs)))] + (return (&/T ?decl =body)))) (defn ^:private mandatory-methods [supers] (|do [class-loader &/loader] (&/flat-map% (partial &host/abstract-methods class-loader) supers))) (defn ^:private check-method-completion [supers methods] - "(-> (List ClassName) (List MethodDesc) (Lux (,)))" + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux (,)))" (|do [abstract-methods (mandatory-methods supers) :let [methods-map (&/fold (fn [mmap mentry] - (assoc mmap (:name mentry) mentry)) + (prn 'methods-map (count mentry) mentry) + (|let [[[=name =modifiers =anns =gvars =exceptions =inputs =output] _] mentry] + (assoc mmap =name mentry))) {} methods) missing-method (&/fold (fn [missing abs-meth] (|let [[am-name am-inputs] abs-meth] (or missing (if-let [meth-struct (get methods-map am-name)] - (let [meth-inputs (:inputs meth-struct)] - (if (and (= (&/|length meth-inputs) (&/|length am-inputs)) - (&/fold2 (fn [prev mi ai] (and prev (= mi ai))) + (|let [[[=name =modifiers =anns =gvars =exceptions =inputs =output] _] meth-struct] + (if (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) true - meth-inputs am-inputs)) + =inputs am-inputs)) nil - am-name)) - am-name)))) + abs-meth)) + abs-meth)))) nil abstract-methods)]] (if (nil? missing-method) (return nil) - (fail (str "[Analyser Error] Missing method: " missing-method))))) + (|let [[am-name am-inputs] missing-method] + (fail (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) -(defn analyse-jvm-class [analyse compile-token name super-class interfaces anns fields methods] +(defn analyse-jvm-class [analyse compile-token class-decl 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% &&a-parser/parse-ann anns) - =fields (&/map% analyse-field fields) - ;; :let [_ (prn 'analyse-jvm-class/_1)] - =method-descs (&/map% dummy-method-desc methods) - _ (&host/use-dummy-class name super-class interfaces &/None$ =fields =method-descs) - =methods (&/map% (partial analyse-method analyse full-name) methods) + :let [[?name ?params] class-decl + full-name (str module "." ?name)] + _ (&host/use-dummy-class class-decl super-class interfaces &/None$ =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl) methods) ;; :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 =anns =fields =methods nil))) - :let [_ (println 'DEF (str module "." name))]] + _ (compile-token (&/V &&/$jvm-class (&/T class-decl super-class interfaces =anns =fields =methods nil))) + :let [_ (println 'DEF full-name)]] (return &/Nil$)))) -(defn analyse-jvm-interface [analyse compile-token interface-decl supers anns methods] +(defn analyse-jvm-interface [analyse compile-token interface-decl supers =anns =methods] (|do [module &/get-module-name - =anns (&/map% &&a-parser/parse-ann anns) - =methods (&/map% &&a-parser/parse-method-decl methods) _ (compile-token (&/V &&/$jvm-interface (&/T interface-decl supers =anns =methods))) :let [_ (println 'DEF (str module "." (&/|first interface-decl)))]] (return &/Nil$))) @@ -608,45 +602,50 @@ :final? false :abstract? false :concurrency nil} - default-<init> {:name "<init>" - :modifiers {:visibility "public" - :static? false - :final? false - :abstract? false - :concurrency nil} - :anns (&/|list) - :exceptions (&/|list) - :inputs (&/|list) - :output "void"} + default-<init> (&/T "<init>" + {:visibility "public" + :static? false + :final? false + :abstract? false + :concurrency nil} + (&/|list) + (&/|list) + (&/|list) + (&/|list) + (&/V &/$GenericClass (&/T "void" (&/|list)))) captured-slot-type "java.lang.Object"] (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces ctor-args methods] (&/with-closure (|do [module &/get-module-name scope &/get-scope-name :let [name (&host/location (&/|tail scope)) - anon-class (str module "." name)] + class-decl (&/T name (&/|list)) + anon-class (str module "." name) + _ (prn 'analyse-jvm-anon-class/_0 anon-class) + _ (prn 'analyse-jvm-anon-class/_1 class-decl) + anon-class-type (&type/Data$ anon-class (&/|list))] =ctor-args (&/map% (fn [ctor-arg] (|let [[arg-type arg-term] ctor-arg] (|do [=arg-term (&&/analyse-1+ analyse arg-term)] (return (&/T arg-type =arg-term))))) ctor-args) - =method-descs (&/map% dummy-method-desc methods) - _ (->> =method-descs + _ (->> methods + (&/|map &/|first) (&/Cons$ default-<init>) - (&host/use-dummy-class name super-class interfaces (&/Some$ =ctor-args) (&/|list))) - =methods (&/map% (partial analyse-method analyse anon-class) methods) + (&host/use-dummy-class class-decl super-class interfaces (&/Some$ =ctor-args) (&/|list))) + =methods (&/map% (partial analyse-method analyse class-decl) methods) _ (check-method-completion (&/Cons$ super-class interfaces) =methods) =captured &&env/captured-vars :let [=fields (&/|map (fn [^objects idx+capt] - {:name (str &c!base/closure-prefix (aget idx+capt 0)) - :modifiers captured-slot-modifier - :anns (&/|list) - :type captured-slot-type}) + (&/T (str &c!base/closure-prefix (aget idx+capt 0)) + captured-slot-modifier + (&/|list) + captured-slot-type)) (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] - _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured (&/Some$ =ctor-args)))) + _ (compile-token (&/V &&/$jvm-class (&/T class-decl super-class interfaces (&/|list) =fields =methods =captured (&/Some$ =ctor-args)))) _cursor &/cursor] - (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor + (return (&/|list (&&/|meta anon-class-type _cursor (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) ))) )))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 3b65d77b1..846b7192b 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -461,7 +461,7 @@ _ (fail ""))) (fn [err] - (fail (str "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) + (fail (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) )) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 192e80153..d0ce0e9c1 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -11,7 +11,8 @@ clojure.core.match.array (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] - [host :as &host]))) + [host :as &host]) + [lux.host.generics :as &host-generics])) ;; [Utils] (deftags @@ -200,7 +201,7 @@ [exported? (&/$ValueD ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str (&host/->class-name module) "." (&/normalize-name name))) + :let [macro (-> (.loadClass loader (str (&host-generics/->class-name module) "." (&/normalize-name name))) (.getField &/datum-field) (.get nil))]] (fn [state*] diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index 238defe69..3625db30c 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -148,23 +148,78 @@ _ (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ast))))) -(defn parse-method-decl [ast] +(defn ^:private parse-arg-decl [ast] (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Nil)))))))))] + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS ["" arg-name])] + (&/$Cons gclass + (&/$Nil))))] + (|do [=gclass (parse-gclass gclass)] + (return (&/T arg-name =gclass))) + + _ + (fail (str "[Analyser Error] Invalid argument declaration: " (&/show-ast ast))))) + +(defn ^:private parse-method-decl* [asts] + (|case asts + (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Cons [_ (&/$TupleS anns)] + (&/$Cons [_ (&/$TupleS gvars)] + (&/$Cons [_ (&/$TupleS exceptions)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons output + *tail*))))))) (|do [=modifiers (parse-modifiers modifiers) =anns (&/map% parse-ann anns) =gvars (&/map% parse-text gvars) - =method-exs (&/map% parse-gclass method-exs) - =inputs (&/map% parse-gclass inputs) + =exceptions (&/map% parse-gclass exceptions) + =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/T method-name =modifiers =anns =gvars =method-exs =inputs =output))) + (return (&/T (&/T method-name =modifiers =anns =gvars =exceptions =inputs =output) + *tail*))) + + _ + (fail (str "[Analyser Error] Invalid method declaration: " (->> asts (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))) + +(defn parse-method-decl [ast] + (|case ast + [_ (&/$FormS tokens)] + (|do [[decl *tail*] (parse-method-decl* tokens)] + (|case *tail* + (&/$Nil) + (return decl) + + _ + (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) _ (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) + +(defn parse-method-def [ast] + (|case ast + [_ (&/$FormS tokens)] + (|do [[decl *tail*] (parse-method-decl* tokens)] + (|case *tail* + (&/$Cons body (&/$Nil)) + (return (&/T decl body)) + + _ + (fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))) + + _ + (fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))) + +(defn parse-field [ast] + (|case ast + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?modifiers)] + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TextS ?type)] + (&/$Nil))))))] + (|do [=modifiers (parse-modifiers ?modifiers) + =anns (&/map% parse-ann ?anns) + =type (parse-gclass ?type)] + (return (&/T ?name =modifiers =anns =type))) + + _ + (fail (str "[Analyser Error] Invalid field declaration: " (&/show-ast ast))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 579d6b33e..baf6bf549 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -18,6 +18,7 @@ [analyser :as &analyser] [optimizer :as &optimizer] [host :as &host]) + [lux.host.generics :as &host-generics] [lux.optimizer :as &o] [lux.analyser.base :as &a] [lux.analyser.module :as &a-module] @@ -467,7 +468,7 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host/->class-name module) "." id)) + (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) (.getField &/eval-field) (.get nil) return)))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index e677406a5..0d9a29d79 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -13,7 +13,8 @@ [type :as &type] [host :as &host]) (lux.analyser [base :as &a] - [module :as &a-module])) + [module :as &a-module]) + [lux.host.generics :as &host-generics]) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -69,7 +70,7 @@ module &/get-module-name loader &/loader !classes &/classes - :let [real-name (str (&host/->class-name module) "." name) + :let [real-name (str (&host-generics/->class-name module) "." name) _ (swap! !classes assoc real-name bytecode) _ (when (not eval?) (write-output module name bytecode)) @@ -79,7 +80,7 @@ (do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>] (do (defn <wrap-name> [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host/->type-signature <class>))))) + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))) (defn <unwrap-name> [^MethodVisitor writer] (doto writer (.visitTypeInsn Opcodes/CHECKCAST <class>) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index b2cc65203..4f5a4b02d 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -12,6 +12,7 @@ (lux [base :as & :refer [|do return* return fail fail* |case |let]] [type :as &type] [host :as &host]) + [lux.host.generics :as &host-generics] (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler [base :as &&] @@ -81,7 +82,7 @@ (if already-loaded? (return true) (if (cached? module) - (let [module* (&host/->class-name module) + (let [module* (&host-generics/->class-name module) module-path (str &&/output-dir module) class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index a02022228..ea12ecc96 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -26,20 +26,20 @@ AnnotationVisitor))) ;; [Utils] -(let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"] - "byte" [(&host/->class "java.lang.Byte") "byteValue" "()B"] - "short" [(&host/->class "java.lang.Short") "shortValue" "()S"] - "int" [(&host/->class "java.lang.Integer") "intValue" "()I"] - "long" [(&host/->class "java.lang.Long") "longValue" "()J"] - "float" [(&host/->class "java.lang.Float") "floatValue" "()F"] - "double" [(&host/->class "java.lang.Double") "doubleValue" "()D"] - "char" [(&host/->class "java.lang.Character") "charValue" "()C"]}] +(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"] + "byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"] + "short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"] + "int" [(&host-generics/->bytecode-class-name "java.lang.Integer") "intValue" "()I"] + "long" [(&host-generics/->bytecode-class-name "java.lang.Long") "longValue" "()J"] + "float" [(&host-generics/->bytecode-class-name "java.lang.Float") "floatValue" "()F"] + "double" [(&host-generics/->bytecode-class-name "java.lang.Double") "doubleValue" "()D"] + "char" [(&host-generics/->bytecode-class-name "java.lang.Character") "charValue" "()C"]}] (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] (if-let [[class method sig] (get class+method+sig class-name)] (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST class) (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class class-name))))) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) (let [boolean-class "java.lang.Boolean" byte-class "java.lang.Byte" @@ -55,28 +55,28 @@ (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) (&/$DataT "byte" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) (&/$DataT "short" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) (&/$DataT "int" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) (&/$DataT "long" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) (&/$DataT "float" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) (&/$DataT "double" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) (&/$DataT "char" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) (&/$DataT _ _) nil @@ -94,7 +94,7 @@ ;; [Resources] (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>] (defn <name> [compile ?x ?y] - (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] + (|do [:let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] ^MethodVisitor *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* @@ -136,7 +136,7 @@ (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>] (defn <name> [compile ?x ?y] - (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] + (|do [:let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] ^MethodVisitor *writer* &/get-writer _ (compile ?y) :let [_ (doto *writer* @@ -150,10 +150,10 @@ $end (new Label) _ (doto *writer* (.visitJumpInsn <opcode> $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) @@ -168,7 +168,7 @@ (do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>] (defn <name> [compile ?x ?y] - (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] + (|do [:let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] ^MethodVisitor *writer* &/get-writer _ (compile ?y) :let [_ (doto *writer* @@ -184,10 +184,10 @@ (.visitInsn <cmpcode>) (.visitLdcInsn (int <cmp-output>)) (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) @@ -207,23 +207,23 @@ (defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type] (|do [^MethodVisitor *writer* &/get-writer =output-type (&host/->java-sig ?output-type) - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" =output-type)] + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&host-type/as-obj ?class)) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) (prepare-return! ?output-type))]] (return nil))) (do-template [<name> <op>] (defn <name> [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] + (|do [:let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer =output-type (&host/->java-sig ?output-type) - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" =output-type)] + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] _ (compile ?object) :let [_ (when (not= "<init>" ?method) (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] @@ -254,17 +254,17 @@ $end (new Label) _ (doto *writer* (.visitJumpInsn Opcodes/IFNULL $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) (defn compile-jvm-new [compile ?class ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V") - class* (&host/->class ?class) + :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") + class* (&host-generics/->bytecode-class-name ?class) _ (doto *writer* (.visitTypeInsn Opcodes/NEW class*) (.visitInsn Opcodes/DUP))] @@ -328,7 +328,7 @@ (|do [^MethodVisitor *writer* &/get-writer _ (compile ?length) :let [_ (.visitInsn *writer* Opcodes/L2I)] - :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/->bytecode-class-name ?class))]] (return nil))) (defn compile-jvm-aaload [compile ?array ?idx] @@ -372,12 +372,12 @@ (|do [^MethodVisitor *writer* &/get-writer =output-type (&host/->java-sig ?output-type) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&host-type/as-obj ?class)) ?field =output-type) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) (prepare-return! ?output-type))]] (return nil))) (defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] - (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] + (|do [:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) =output-type (&host/->java-sig ?output-type) @@ -391,12 +391,12 @@ (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) =output-type (&host/->java-sig ?output-type) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&host-type/as-obj ?class)) ?field =output-type)] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type)] :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) (defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] - (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] + (|do [:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (.visitInsn *writer* Opcodes/DUP)] @@ -407,7 +407,7 @@ (return nil))) (defn compile-jvm-instanceof [compile class object] - (|do [:let [class* (&host/->class class)] + (|do [:let [class* (&host-generics/->bytecode-class-name class)] ^MethodVisitor *writer* &/get-writer _ (compile object) :let [_ (doto *writer* @@ -416,7 +416,7 @@ (return nil))) (defn ^:private compile-annotation [writer ann] - (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true) + (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->bytecode-class-name (:name ann)) true) (-> (.visit param-name param-value) (->> (|let [[param-name param-value] param]) (doseq [param (&/->seq (:params ann))]))) @@ -424,11 +424,12 @@ nil) (defn ^:private compile-field [^ClassWriter 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)) + (|let [[=name =modifiers =anns =type] field + =field (.visitField writer (&host/modifiers->int =modifiers) =name + (&host-generics/->type-signature =type) nil nil)] + (do (&/|map (partial compile-annotation =field) =anns) + (.visitEnd =field) + nil))) (defn ^:private compile-method-return [^MethodVisitor writer output] (case output @@ -460,32 +461,34 @@ ;; else (.visitInsn writer Opcodes/ARETURN))) -(defn ^:private compile-method [compile ^ClassWriter class-writer method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) - (:name method) - signature - nil - (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) +(defn ^:private compile-method-def [compile ^ClassWriter class-writer method-def] + (|let [[=method-decl =body] method-def + [=name =modifiers =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer (&host/modifiers->int =modifiers) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) (:anns method)) + :let [_ (&/|map (partial compile-annotation =method) =anns) _ (.visitCode =method)] - _ (compile (:body method)) + _ (compile =body) :let [_ (doto =method - (compile-method-return (:output method)) + (compile-method-return =output) (.visitMaxs 0 0) (.visitEnd))]] (return nil))))) -(defn ^:private compile-method-decl [^ClassWriter class-writer method] - (|let [[=name =modifiers =anns =gvars =exceptions =inputs =output] method - simple-signature (str "(" (&/fold str "" (&/|map &host-generics/gclass->simple-signature =inputs)) ")" (&host-generics/gclass->simple-signature =output)) - generic-signature (str "<" (->> =gvars (&/|interpose " ") (&/fold str "")) ">" - "(" (&/fold str "" (&/|map &host-generics/gclass->signature =inputs)) ")" - (&host-generics/gclass->signature =output) - (->> =exceptions (&/|map &host-generics/gclass->signature) (&/|interpose " ") (&/fold str ""))) - =method (.visitMethod class-writer (&host/modifiers->int =modifiers) =name simple-signature generic-signature (->> =exceptions (&/|map &host-generics/gclass->simple-signature) &/->seq (into-array java.lang.String))) +(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] + (|let [[=name =modifiers =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) + =method (.visitMethod class-writer + (&host/modifiers->int =modifiers) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->simple-signature) &/->seq (into-array java.lang.String))) _ (&/|map (partial compile-annotation =method) =anns) _ (.visitEnd =method)] nil)) @@ -493,34 +496,34 @@ (defn ^:private prepare-ctor-arg [^MethodVisitor writer type] (case type "boolean" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Boolean")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Boolean")) &&/unwrap-boolean) "byte" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Byte")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Byte")) &&/unwrap-byte) "short" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Short")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Short")) &&/unwrap-short) "int" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Integer")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Integer")) &&/unwrap-int) "long" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Long")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Long")) &&/unwrap-long) "float" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Float")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Float")) &&/unwrap-float) "double" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Double")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Double")) &&/unwrap-double) "char" (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Character")) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Character")) &&/unwrap-char) ;; else (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class type))))) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) -(let [clo-field-sig (&host/->type-signature "java.lang.Object") +(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") init-method "<init>" <init>-return "V"] (defn ^:private anon-class-<init>-signature [env] @@ -528,7 +531,7 @@ <init>-return)) (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args] - (let [init-types (->> ctor-args (&/|map (comp &host/->type-signature &/|first)) (&/fold str ""))] + (let [init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil) (|do [^MethodVisitor =method &/get-writer :let [_ (doto =method (.visitCode) @@ -540,7 +543,7 @@ (return nil)))) ctor-args) :let [_ (doto =method - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host/->class super-class) init-method (str "(" init-types ")" <init>-return)) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class) init-method (str "(" init-types ")" <init>-return)) (-> (doto (.visitVarInsn Opcodes/ALOAD 0) (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) @@ -554,19 +557,23 @@ (return nil))))) ) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env ??ctor-args] +(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?anns ?fields ?methods env ??ctor-args] (|do [module &/get-module-name [file-name _ _] &/cursor - :let [full-name (str module "/" ?name) - super-class* (&host/->class ?super-class) + :let [[?name ?params] class-decl + _ (prn 'compile-jvm-class/_0 class-decl ?name) + class-signature (&host-generics/gclass-decl->signature class-decl (&/Cons$ ?super-class ?interfaces)) + full-name (str module "/" ?name) + _ (prn 'compile-jvm-class/_1 full-name class-signature) + super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) + full-name nil super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) (.visitSource file-name nil)) _ (&/|map (partial compile-annotation =class) ?anns) _ (&/|map (partial compile-field =class) ?fields)] - _ (&/map% (partial compile-method compile =class) ?methods) + _ (&/map% (partial compile-method-def compile =class) ?methods) _ (|case ??ctor-args (&/$Some ctor-args) (add-anon-class-<init> =class compile full-name ?super-class env ctor-args) @@ -584,7 +591,7 @@ (str module "/" interface-name) (&host-generics/gclass-decl->signature interface-decl ?supers) "java/lang/Object" - (->> ?supers (&/|map (comp &host/->class &host-generics/super-class-name)) &/->seq (into-array String))) + (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) (.visitSource file-name nil)) _ (&/|map (partial compile-annotation =interface) ?anns) _ (do (&/|map (partial compile-method-decl =interface) ?methods) @@ -611,7 +618,7 @@ ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)] (doto *writer* - (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) + (.visitTryCatchBlock $from $to $handler-start (&host-generics/->bytecode-class-name ?ex-class)) (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)] :let [_ (.visitLabel *writer* $from)] @@ -663,14 +670,14 @@ (defn <name> [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW (&host/->class <to-class>)) + (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name <to-class>)) (.visitInsn Opcodes/DUP))] _ (compile ?value) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class <from-class>)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <from-class>) <from-method> <from-sig>) + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from-class>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from-class>) <from-method> <from-sig>) (.visitInsn <op>) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host/->class <to-class>) "<init>" <to-sig>))]] + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) "<init>" <to-sig>))]] (return nil))) compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V" @@ -697,19 +704,19 @@ (defn <name> [compile ?x ?y] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW (&host/->class <to-class>)) + (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name <to-class>)) (.visitInsn Opcodes/DUP))] _ (compile ?x) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class <from1-class>)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <from1-class>) <from1-method> <from1-sig>))] + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from1-class>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from1-class>) <from1-method> <from1-sig>))] _ (compile ?y) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class <from2-class>)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <from2-class>) <from2-method> <from2-sig>))] + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from2-class>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from2-class>) <from2-method> <from2-sig>))] :let [_ (doto *writer* (.visitInsn <op>) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host/->class <to-class>) "<init>" <to-sig>))]] + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) "<init>" <to-sig>))]] (return nil))) compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index a719084ab..83714517f 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -15,6 +15,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.host.generics :as &host-generics] [lux.analyser.base :as &a] (lux.compiler [base :as &&])) (:import (org.objectweb.asm Opcodes @@ -23,8 +24,8 @@ MethodVisitor))) ;; [Utils] -(def ^:private clo-field-sig (&host/->type-signature "java.lang.Object")) -(def ^:private lambda-return-sig (&host/->type-signature "java.lang.Object")) +(def ^:private clo-field-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) (def ^:private <init>-return "V") (def ^:private lambda-impl-signature diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 4548f2bc4..21494908a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -15,6 +15,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.host.generics :as &host-generics] (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler [base :as &&] @@ -211,7 +212,7 @@ :let [_ (.visitEnd *writer*)] _ (&&/save-class! def-name (.toByteArray =class)) class-loader &/loader - :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))] _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] (return nil)))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 8c73246c7..5807d711a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -10,9 +10,9 @@ clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) - [lux.type.host :as &host-type]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics]) (:import (java.lang.reflect Field Method Constructor Modifier Type) - java.util.regex.Pattern (org.objectweb.asm Opcodes Label ClassWriter @@ -27,37 +27,11 @@ (def bytecode-version Opcodes/V1_6) ;; [Resources] -(do-template [<name> <old-sep> <new-sep>] - (let [regex (-> <old-sep> Pattern/quote re-pattern)] - (defn <name> [old] - (string/replace old regex <new-sep>))) - - ^String ->class class-name-separator class-separator - ^String ->class-name module-separator class-name-separator - ^String ->module-class module-separator class-separator - ) +(defn ^String ->module-class [old] + old) (def ->package ->module-class) -(defn ->type-signature [class] - ;; (assert (string? class)) - (case class - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ;; else - (let [class* (->class class)] - (if (.startsWith class* "[") - class* - (str "L" class* ";"))) - )) - (defn unfold-array [type] "(-> Type (, Int Type))" (|case type @@ -68,8 +42,8 @@ _ (&/T 0 type))) -(let [ex-type-class (str "L" (->class "java.lang.Object") ";") - object-array (str "[" "L" (->class "java.lang.Object") ";")] +(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") + object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] (defn ->java-sig [^objects type] "(-> Type (Lux Text))" (|case type @@ -77,17 +51,17 @@ (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] base-sig (|case base (&/$DataT base-class _) - (return (->type-signature base-class)) + (return (&host-generics/->type-signature base-class)) _ (->java-sig base))] (return (str (->> (&/|repeat level "[") (&/fold str "")) base-sig))) - (= &host-type/null-data-tag ?name) (return (->type-signature "java.lang.Object")) - :else (return (->type-signature ?name))) + (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object")) + :else (return (&host-generics/->type-signature ?name))) (&/$LambdaT _ _) - (return (->type-signature function-class)) + (return (&host-generics/->type-signature function-class)) (&/$TupleT (&/$Nil)) (return "V") @@ -171,10 +145,12 @@ (return (&/T exs gvars gargs))) (fail (str "[Host Error] Constructor does not exist: " target))))) -(defn abstract-methods [class-loader class] - (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) - :when (Modifier/isAbstract (.getModifiers =method))] - (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) +(defn abstract-methods [class-loader super-class] + "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" + (|let [[super-name super-params] super-class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj super-name) true class-loader)) + :when (Modifier/isAbstract (.getModifiers =method))] + (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method)))))))))) (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) @@ -227,16 +203,16 @@ (case output "void" (if (= "<init>" name) (|let [(&/$Some ctor-args) ??ctor-args - ctor-arg-types (->> ctor-args (&/|map (comp ->type-signature &/|first)) (&/fold str ""))] + ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] (doto writer (.visitVarInsn Opcodes/ALOAD 0) (-> (doto (dummy-value arg-type) - (-> (.visitTypeInsn Opcodes/CHECKCAST (->class arg-type)) + (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) (->> (when (not (primitive-jvm-type? arg-type)))))) (->> (doseq [ctor-arg (&/->seq ctor-args) :let [;; arg-term (&/|first ctor-arg) arg-type (&/|first ctor-arg)]]))) - (.visitMethodInsn Opcodes/INVOKESPECIAL (->class super-class) "<init>" (str "(" ctor-arg-types ")V")) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class) "<init>" (str "(" ctor-arg-types ")V")) (.visitInsn Opcodes/RETURN))) (.visitInsn writer Opcodes/RETURN)) "boolean" (doto writer @@ -268,34 +244,42 @@ (.visitInsn Opcodes/ACONST_NULL) (.visitInsn Opcodes/ARETURN)))) -(defn use-dummy-class [name super-class interfaces ctor-args fields methods] +(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] (|do [module &/get-module-name - :let [full-name (str module "/" name) + :let [[?name ?params] class-decl + full-name (str module "/" ?name) + class-signature (&host-generics/gclass-decl->signature class-decl interfaces) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil (->class super-class) (->> interfaces (&/|map ->class) &/->seq (into-array String)))) + full-name + class-signature + (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) + (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (->type-signature (:type field)) nil nil) - (.visitEnd))) + (|let [[=name =modifiers =anns =type] field] + (doto (.visitField =class (modifiers->int =modifiers) =name + (&host-generics/->type-signature =type) nil nil) + (.visitEnd)))) fields) - _ (&/|map (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map ->type-signature (:inputs method))) ")" - (->type-signature (:output method)))] - (doto (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature - nil - (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String))) + _ (&/|map (fn [method-decl] + (prn 'use-dummy-class (count method-decl) method-decl) + (|let [[=name =modifiers =anns =gvars =exceptions =inputs =output] method-decl + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (modifiers->int =modifiers) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) .visitCode - (dummy-return super-class ctor-args (:name method) (:output method)) + (dummy-return super-class ctor-args =name =output) (.visitMaxs 0 0) (.visitEnd)))) methods) bytecode (.toByteArray (doto =class .visitEnd))] ^ClassLoader loader &/loader !classes &/classes - :let [real-name (str (->class-name module) "." name) + :let [real-name (str (&host-generics/->class-name module) "." ?name) + _ (prn 'use-dummy-class/_0 ?name real-name) _ (swap! !classes assoc real-name bytecode) _ (.loadClass loader real-name)]] (return nil))) diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj index 9ec451ed6..4fd2c3269 100644 --- a/src/lux/host/generics.clj +++ b/src/lux/host/generics.clj @@ -4,17 +4,51 @@ ;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.host.generics - (:require (clojure [template :refer [do-template]]) + (:require (clojure [string :as string] + [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [host :as &host]))) + (lux [base :as & :refer [|do return* return fail fail* |let |case]])) + (:import java.util.regex.Pattern)) + +(do-template [<name> <old-sep> <new-sep>] + (let [regex (-> <old-sep> Pattern/quote re-pattern)] + (defn <name> [old] + (string/replace old regex <new-sep>))) + + ;; ->class + ^String ->bytecode-class-name "." "/" + ;; ->class-name + ^String ->class-name "/" "." + ) + +;; ->type-signature +(defn ->type-signature [class] + (case class + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (let [class* (->bytecode-class-name class)] + (if (.startsWith class* "[") + class* + (str "L" class* ";"))) + )) (defn super-class-name [super] "(-> GenericSuperClassDecl Text)" (|let [[super-name super-params] super] super-name)) +(defn class-decl-params->signature [params] + (str "<" (->> params (&/|interpose " ") (&/fold str "")) ">")) + (defn gclass->signature [super] "(-> GenericClass Text)" (|case super @@ -22,8 +56,8 @@ (str "T" name ";") (&/$GenericClass name params) - (|let [params-sigs (->> params (&/|map gclass->signature) (&/|interpose " ") (&/fold str ""))] - (str "L" (&host/->class name) "<" params-sigs ">" ";")) + (let [params* (str "<" (->> params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">")] + (str "L" (->bytecode-class-name name) params* ";")) (&/$GenericArray param) (str "[" (gclass->signature param)))) @@ -31,17 +65,17 @@ (defn gsuper-decl->signature [super] "(-> GenericSuperClassDecl Text)" (|let [[super-name super-params] super - params-sigs (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str ""))] - (str "L" (&host/->class super-name) "<" params-sigs ">" ";"))) + params* (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">")] + (str "L" (->bytecode-class-name super-name) params* ";"))) (defn gclass-decl->signature [class-decl supers] "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" (|let [[class-name class-vars] class-decl - vars-section (str "<" (->> class-vars (&/|interpose " ") (&/fold str "")) ">") + vars-section (class-decl-params->signature class-vars) super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] (str vars-section super-section))) -(let [object-simple-signature (&host/->type-signature "java.lang.Object")] +(let [object-simple-signature (->type-signature "java.lang.Object")] (defn gclass->simple-signature [gclass] "(-> GenericClass Text)" (|case gclass @@ -49,7 +83,29 @@ object-simple-signature (&/$GenericClass name params) - (&host/->type-signature name) + (->type-signature name) (&/$GenericArray param) (str "[" (gclass->simple-signature param))))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name doesn't work on arrays.")))) + +(defn method-signatures [method-decl] + (|let [[=name =modifiers =anns =gvars =exceptions =inputs =output] method-decl + simple-signature (str "(" (&/fold str "" (&/|map (comp gclass->simple-signature &/|second) =inputs)) ")" (gclass->simple-signature =output)) + generic-signature (str "<" (->> =gvars (&/|interpose " ") (&/fold str "")) ">" + "(" (&/fold str "" (&/|map (comp gclass->signature &/|second) =inputs)) ")" + (gclass->signature =output) + (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] + (&/T simple-signature generic-signature))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 491e81b3b..07ab0be1c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -401,8 +401,9 @@ (&/Cons$ (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] - (str "[Type Checker]\nExpected: " (show-type expected) - "\n\nActual: " (show-type actual) + (str "[Type Checker]\n" + "Expected: " (show-type expected) "\n\n" + "Actual: " (show-type actual) "\n")) (defn beta-reduce [env type] |