From ceb21fc9cccc07dc562e386f6f07a9b930cfb49f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 9 Mar 2016 19:03:53 -0400 Subject: - Fixed a bug wherein type-variables were not getting properly cleaned and that was causing trouble with type-checking. - Fixed a bug in the way arguments for method-definitions were getting compiled. - Fixed a bug in the way double greater-than comparison was being compiled. - Fixed how exception signatures were getting compiled for method-definitions. --- src/lux/analyser.clj | 10 +++++--- src/lux/analyser/host.clj | 46 ++++++++++++++++++--------------- src/lux/analyser/lux.clj | 7 +++--- src/lux/base.clj | 11 ++------ src/lux/compiler/cache.clj | 2 ++ src/lux/compiler/host.clj | 63 +++++++++++++++++++++++++--------------------- src/lux/type.clj | 54 +++++++++++++++++++++++++++++++++------ 7 files changed, 120 insertions(+), 73 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 80c8ef2ec..42d92b859 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -668,12 +668,14 @@ (|case [?var ?output-type] [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) - (|do [?output-type* (&type/deref ?e-id)] - (return (&&/|meta ?output-type* ?output-cursor ?output-term))) - (return (&&/|meta ?output-type ?output-cursor ?output-term))) + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term))) + (|do [=output-type (&type/clean ?var ?var)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) [_ _] - (return (&&/|meta ?output-type ?output-cursor ?output-term))) + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index d431ddb9f..a2d6fd592 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -575,6 +575,28 @@ (return (&/T [gvar-name ex])))) type-params)) +(defn ^:private double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn ^:private method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &/$VoidT + body*)) + (&&env/with-local iname itype + body*))))) + (defn ^:private analyse-method [analyse class-decl class-env all-supers method] "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" (|let [[?cname ?cparams] class-decl @@ -592,11 +614,7 @@ ?ctor-args) =body (&/with-type-env full-env (&&env/with-local &&/jvm-this class-type - (&/fold (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (&&env/with-local iname itype - body*))) + (&/fold (method-input-folder full-env) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) @@ -607,11 +625,7 @@ output-type (generic-class->type full-env ?output) =body (&/with-type-env full-env (&&env/with-local &&/jvm-this class-type - (&/fold (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (&&env/with-local iname itype - body*))) + (&/fold (method-input-folder full-env) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) @@ -623,11 +637,7 @@ output-type (generic-class->type full-env ?output) =body (&/with-type-env full-env (&&env/with-local &&/jvm-this class-type - (&/fold (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (&&env/with-local iname itype - body*))) + (&/fold (method-input-folder full-env) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) @@ -637,11 +647,7 @@ :let [full-env method-env] output-type (generic-class->type full-env ?output) =body (&/with-type-env full-env - (&/fold (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (&&env/with-local iname itype - body*))) + (&/fold (method-input-folder full-env) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs)))] (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 88fc2f4ee..4ffa7a9c2 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -339,8 +339,9 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/$BoundT 1))] - (&type/clean $var =output-t)))] + (|do [_ (&type/set-var ?id (next-bound-type =output-t))] + (&type/clean $var =output-t))) + _ (&type/clean $var exo-type)] (return (&/T [type** ==args]))) )))) @@ -385,7 +386,7 @@ (throw e)))))) module-name &/get-module-name ;; :let [[r-prefix r-name] real-name - ;; _ (when (or (= "jvm-import" r-name) + ;; _ (when (or (= "get@" r-name) ;; ;; (= "defclass" r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) diff --git a/src/lux/base.clj b/src/lux/base.clj index 4074efae7..56a59e31b 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -693,16 +693,9 @@ (proxy [java.lang.ClassLoader] [] (findClass [^String class-name] - ;; (prn 'findClass class-name) (if-let [^bytes bytecode (get @store class-name)] - (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) - (catch java.lang.reflect.InvocationTargetException e - ;; (prn 'InvocationTargetException (.getCause e)) - ;; (prn 'InvocationTargetException (.getTargetException e)) - ;; (prn 'memory-class-loader/findClass class-name (get @store class-name)) - (throw e))) - (do ;; (prn 'memory-class-loader/store class-name (keys @store)) - (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) + (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) ;; (deftype Host ;; (& #writer (^ org.objectweb.asm.ClassWriter) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index acbe2e6b9..8ae2eb113 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -108,6 +108,8 @@ (let [real-name (second (re-find #"^(.*)\.class$" file-name)) bytecode (read-file file)] (swap! !classes assoc (str module* "." real-name) bytecode))) + ;; (doseq [_class-name_ (keys @!classes)] + ;; (&&/load-class! loader _class-name_)) (let [defs (string/split (get-field &/defs-field module-meta) def-separator-re) tag-groups (let [all-tags (get-field &/tags-field module-meta)] (if (= "" all-tags) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 88cb1ee6e..79658e6d5 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -193,9 +193,9 @@ (.visitLabel $end))]] (return nil))) - compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" - compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" - compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" + compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" @@ -203,7 +203,7 @@ compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D" - compile-jvm-dgt Opcodes/FCMPG 1 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" ) (defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type] @@ -515,65 +515,66 @@ (.visitVarInsn Opcodes/ILOAD idx) &&/wrap-boolean (.visitVarInsn Opcodes/ASTORE idx)) - (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) "byte" (do (doto method-visitor (.visitVarInsn Opcodes/ILOAD idx) &&/wrap-byte (.visitVarInsn Opcodes/ASTORE idx)) - (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) "short" (do (doto method-visitor (.visitVarInsn Opcodes/ILOAD idx) &&/wrap-short (.visitVarInsn Opcodes/ASTORE idx)) - (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) "int" (do (doto method-visitor (.visitVarInsn Opcodes/ILOAD idx) &&/wrap-int (.visitVarInsn Opcodes/ASTORE idx)) - (return Opcodes/INTEGER)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) "long" (do (doto method-visitor (.visitVarInsn Opcodes/LLOAD idx) &&/wrap-long (.visitVarInsn Opcodes/ASTORE idx)) - (return Opcodes/LONG)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) "float" (do (doto method-visitor (.visitVarInsn Opcodes/FLOAD idx) &&/wrap-float (.visitVarInsn Opcodes/ASTORE idx)) - (return Opcodes/FLOAT)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) "double" (do (doto method-visitor (.visitVarInsn Opcodes/DLOAD idx) &&/wrap-double (.visitVarInsn Opcodes/ASTORE idx)) - (return Opcodes/DOUBLE)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) "char" (do (doto method-visitor (.visitVarInsn Opcodes/ILOAD idx) &&/wrap-char (.visitVarInsn Opcodes/ASTORE idx)) - (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) ;; else - (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) [_ gclass] - (return (&host-generics/gclass->class-name gclass)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) )) (defn ^:private prepare-method-inputs [idx inputs method-visitor] "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" (|case inputs (&/$Nil) - (return &/unit-tag) + (return &/$Nil) (&/$Cons input inputs*) - (let [!idx (atom idx)] - (&/map% (fn [input] - (|do [output (prepare-method-input @!idx input method-visitor) - :let [_ (swap! !idx inc)]] - (return output))) - inputs)) + (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] + (|do [:let [[_idx _outputs] idx+outputs] + [idx* output] (prepare-method-input _idx input method-visitor)] + (return (&/T [idx* (&/$Cons output _outputs)])))) + (&/T [idx &/$Nil]) + inputs)] + (return (&/list-join (&/|reverse outputs*)))) )) -(defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def] +(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] (|case method-def (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) (|let [?output (&/$GenericClass "void" (&/|list)) @@ -585,7 +586,7 @@ init-method simple-signature generic-signature - (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [[super-class-name super-class-params] ?super-class init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) @@ -593,6 +594,7 @@ _ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons Opcodes/UNINITIALIZED_THIS =input-tags))) (int 0) (to-array []))] :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] @@ -613,11 +615,12 @@ ?name simple-signature generic-signature - (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons bytecode-class-name =input-tags))) (int 0) (to-array []))] _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) @@ -634,11 +637,12 @@ ?name simple-signature generic-signature - (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons bytecode-class-name =input-tags))) (int 0) (to-array []))] _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) @@ -656,11 +660,12 @@ ?name simple-signature generic-signature - (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] =input-tags (prepare-method-inputs 0 ?inputs =method) + :let [_ (.visitFrame =method Opcodes/F_NEW (int (&/|length =input-tags)) (to-array (&/->seq =input-tags)) (int 0) (to-array []))] _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) @@ -677,7 +682,7 @@ ?name simple-signature generic-signature - (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitEnd =method)]] @@ -692,7 +697,7 @@ ?name simple-signature generic-signature - (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitEnd =method)]] @@ -806,7 +811,7 @@ _ (&/|map (partial compile-annotation =class) ?anns) _ (&/|map (partial compile-field =class) ?fields)] - _ (&/map% (partial compile-method-def compile =class ?super-class) ?methods) + _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) _ (|case ??ctor-args (&/$Some ctor-args) (add-anon-class- =class compile full-name ?super-class env ctor-args) diff --git a/src/lux/type.clj b/src/lux/type.clj index b09db681d..e9ebcc361 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -192,6 +192,24 @@ nil)) (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) +(defn reset-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) + ts)) + state) + nil) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +(defn unset-var [id] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) + ts)) + state) + nil) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + ;; [Exports] ;; Type vars (def ^:private create-var @@ -256,7 +274,23 @@ (if ? (deref ?id) (return type))) - (return type)) + (|do [? (bound? ?id)] + (if ? + (|do [=type (deref ?id) + ==type (clean* ?tid =type)] + (|case ==type + (&/$VarT =id) + (if (.equals ^Object ?tid =id) + (|do [_ (unset-var ?id)] + (return type)) + (|do [_ (reset-var ?id ==type)] + (return type))) + + _ + (|do [_ (reset-var ?id ==type)] + (return type)))) + (return type))) + ) (&/$DataT ?name ?params) (|do [=params (&/map% (partial clean* ?tid) ?params)] @@ -714,17 +748,21 @@ [_ (&/$UnivQ _)] (with-var (fn [$arg] - (|do [actual* (apply-type actual $arg)] - (check* class-loader fixpoints invariant?? expected actual*)))) + (|do [actual* (apply-type actual $arg) + =output (check* class-loader fixpoints invariant?? expected actual*) + _ (clean $arg expected)] + (return =output)))) [(&/$ExQ e!env e!def) _] (with-var (fn [$arg] - (|let [expected* (beta-reduce (->> e!env - (&/$Cons $arg) - (&/$Cons expected)) - e!def)] - (check* class-loader fixpoints invariant?? expected* actual)))) + (|do [:let [expected* (beta-reduce (->> e!env + (&/$Cons $arg) + (&/$Cons expected)) + e!def)] + =output (check* class-loader fixpoints invariant?? expected* actual) + _ (clean $arg actual)] + (return =output)))) [_ (&/$ExQ a!env a!def)] (|do [$arg existential] -- cgit v1.2.3