From 0fbbced7029ae8dc05b63c618bc6dd30aeef8b09 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 16:17:03 -0400 Subject: - Finished some missing bits of class definition analysis. --- src/lux/analyser/host.clj | 54 ++++++++++++++++++++++++++++-------- src/lux/compiler/host.clj | 36 ++++++++++++++++++++++-- src/lux/host.clj | 70 +++++++++++++++++++++++++++++++++++++++++------ src/lux/type.clj | 50 ++++++++++++++++++--------------- 4 files changed, 165 insertions(+), 45 deletions(-) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9d295edda..53ab1de5b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -425,15 +425,45 @@ _ (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-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-exs (&/map% extract-text method-exs) + =method-inputs (&/map% (fn [minput] + (|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 + :exceptions =method-exs + :inputs (&/|map &/|second =method-inputs) + :output method-output})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + (defn ^:private analyse-method [analyse owner-class method] (|case method - [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))]] + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] @@ -521,8 +551,9 @@ ;; :let [_ (prn 'analyse-jvm-class/_0)] =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] - _ (&host/use-dummy-class name super-class interfaces =fields) - =methods (&/map% (partial analyse-method analyse full-name) (&/enumerate methods)) + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces =fields =method-descs) + =methods (&/map% (partial analyse-method analyse full-name) methods) ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] @@ -557,8 +588,9 @@ :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] - _ (&host/use-dummy-class name super-class interfaces (&/|list)) - =methods (&/map% (partial analyse-method analyse anon-class) (&/enumerate methods)) + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs) + =methods (&/map% (partial analyse-method analyse anon-class) methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index b4858d789..95d63b0fb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -410,6 +410,36 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-method-return [writer output] + (case output + "void" (.visitInsn writer Opcodes/RETURN) + "boolean" (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + ;; else + (.visitInsn writer Opcodes/ARETURN))) + (defn ^:private compile-method [compile class-writer method] ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) @@ -421,12 +451,12 @@ (:name method) signature nil - (->> (:exceptions method) &/->seq (into-array java.lang.String))) + (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (.visitCode =method)] _ (compile (:body method)) :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (compile-method-return (:output method)) (.visitMaxs 0 0) (.visitEnd))]] (return nil))))) @@ -434,7 +464,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) &/->seq (into-array java.lang.String))))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] diff --git a/src/lux/host.clj b/src/lux/host.clj index d2ade63c7..b05c30ad3 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -68,14 +68,15 @@ (class->type (.getReturnType method))) ;; [Resources] -(defn ^String ->class [class] - (string/replace class (-> class-name-separator Pattern/quote re-pattern) class-separator)) - -(defn ^String ->class-name [module] - (string/replace module (-> module-separator Pattern/quote re-pattern) class-name-separator)) - -(defn ^String ->module-class [module-name] - (string/replace module-name (-> module-separator Pattern/quote re-pattern) class-separator)) +(do-template [ ] + (let [regex (-> Pattern/quote re-pattern)] + (defn [old] + (string/replace old regex ))) + + ^String ->class class-name-separator class-separator + ^String ->class-name module-separator class-name-separator + ^String ->module-class module-separator class-separator + ) (def ->package ->module-class) @@ -206,7 +207,45 @@ ;; else 0))) -(defn use-dummy-class [name super-class interfaces fields] +(let [object-real-class (->class "java.lang.Object")] + (defn ^:private dummy-return [writer name output] + (case output + "void" (if (= "" name) + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL object-real-class "" "()V") + (.visitInsn Opcodes/RETURN)) + (.visitInsn writer Opcodes/RETURN)) + "boolean" (doto writer + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + (.visitLdcInsn (byte 0)) + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + (.visitLdcInsn (short 0)) + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + (.visitLdcInsn (float 0.0)) + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + (.visitLdcInsn (double 0.0)) + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + (.visitLdcInsn (char 0)) + (.visitInsn Opcodes/IRETURN)) + ;; else + (doto writer + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN))))) + +(defn use-dummy-class [name super-class interfaces fields methods] (|do [module &/get-module-name :let [full-name (str module "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -217,6 +256,19 @@ (->type-signature (:type field)) 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))) + .visitCode + (dummy-return (:name method) (:output method)) + (.visitMaxs 0 0) + (.visitEnd)))) + methods) bytecode (.toByteArray (doto =class .visitEnd))] loader &/loader !classes &/classes diff --git a/src/lux/type.clj b/src/lux/type.clj index 24486c85a..0495e6b02 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -663,31 +663,37 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] - (if (contains? primitive-types e!name) - (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) - [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] - (cond (and (.equals ^Object e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - (return (&/T fixpoints nil))) - - (and (not invariant??) - ;; (do (println '[Data Data] [e!name a!name] - ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) - ;; true) - (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) - (catch Exception e - (prn 'FAILED_HERE e!name a!name)))) + (cond (= "#Null" a!name) + (if (not (contains? primitive-types e!name)) (return (&/T fixpoints nil)) + (fail (check-error expected actual))) - :else - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) + (= "#Null" e!name) + (if (= "#Null" a!name) + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) + + :else + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (and (.equals ^Object e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + (return (&/T fixpoints nil))) + + (and (not invariant??) + ;; (do (println '[Data Data] [e!name a!name] + ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) + ;; true) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) + (return (&/T fixpoints nil)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] -- cgit v1.2.3