From a97ad4c73cb30176696b3ddf65dc2de62aafb2c6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 29 Feb 2016 13:38:31 -0400 Subject: - VarT and ExT types are now treated as java.lang.Object. - Now wrapping primitive method arguments inside objects, as Lux code always assumes everything is an object. - Now using a hand-made text lexer, that is less tolerant of escaping-cleanup errors. - When packaging the contents of dependency JARs inside the output program JAR, the compressed size of the entries is recalculated with (.setCompressedSize -1), in order to avoid errors in the JarOutputStream. --- src/lux/analyser/host.clj | 6 +++ src/lux/analyser/lux.clj | 27 ++++++----- src/lux/base.clj | 4 +- src/lux/compiler/host.clj | 79 +++++++++++++++++++++++++++++-- src/lux/lexer.clj | 110 +++++++++++++++++++++++++++++++------------ src/lux/packager/program.clj | 27 ++++++----- 6 files changed, 193 insertions(+), 60 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index c4b77cfdd..d431ddb9f 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -62,6 +62,12 @@ (&/$DataT payload) (return payload) + (&/$VarT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$ExT id) + (return (&/T ["java.lang.Object" (&/|list)])) + (&/$NamedT _ type*) (ensure-object type*) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 98c734372..88fc2f4ee 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -212,7 +212,7 @@ _ (return exo-type))] (fail (str err "\n" - 'analyse-variant " " idx " " is-last? " " is-last?* " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + 'analyse-variant " " idx " " is-last? " " is-last?* " " (&type/show-type _exo-type) " " (&type/show-type vtype) " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) _cursor &/cursor] (if (= 1 num-variant-types) @@ -378,16 +378,21 @@ (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) - (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state))) - :let [[r-prefix r-name] real-name - ;; _ (when (or (= "defclass" r-name) - ;; ;; (= "@type" r-name) - ;; ) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name)))) - ] + (|do [macro-expansion (fn [state] (try (-> ?value (.apply ?args) (.apply state)) + (catch java.lang.StackOverflowError e + (|let [[r-prefix r-name] real-name] + (do (prn 'find-def [r-prefix r-name]) + (throw e)))))) + module-name &/get-module-name + ;; :let [[r-prefix r-name] real-name + ;; _ (when (or (= "jvm-import" r-name) + ;; ;; (= "defclass" r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name) module-name))) + ;; ] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/src/lux/base.clj b/src/lux/base.clj index 5e46694e2..4074efae7 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -310,7 +310,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) v - (|get slot table*)))) + (recur slot table*)))) (defn |put [slot value table] (|case table @@ -933,7 +933,7 @@ (pr-str ?value) [_ ($CharS ?value)] - (pr-str ?value) + (str "#\"" (pr-str ?value) "\"") [_ ($TextS ?value)] (str "\"" ?value "\"") diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 05080c3ed..67dcfbd5c 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -506,6 +506,73 @@ _ (.visitInsn writer Opcodes/ARETURN))) +(defn ^:private prepare-method-input [idx input method-visitor] + "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + (|case input + [_ (&/$GenericClass name params)] + (case name + "boolean" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-boolean + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + "byte" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-byte + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + "short" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-short + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + "int" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-int + (.visitVarInsn Opcodes/ASTORE idx)) + (return Opcodes/INTEGER)) + "long" (do (doto method-visitor + (.visitVarInsn Opcodes/LLOAD idx) + &&/wrap-long + (.visitVarInsn Opcodes/ASTORE idx)) + (return Opcodes/LONG)) + "float" (do (doto method-visitor + (.visitVarInsn Opcodes/FLOAD idx) + &&/wrap-float + (.visitVarInsn Opcodes/ASTORE idx)) + (return Opcodes/FLOAT)) + "double" (do (doto method-visitor + (.visitVarInsn Opcodes/DLOAD idx) + &&/wrap-double + (.visitVarInsn Opcodes/ASTORE idx)) + (return Opcodes/DOUBLE)) + "char" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-char + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + ;; else + (return (&host-generics/gclass->class-name (&/$GenericClass name params)))) + + [_ gclass] + (return (&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) + + (&/$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)) + )) + (defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def] (|case method-def (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) @@ -524,12 +591,11 @@ init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) init-sig (str "(" init-types ")" "V") _ (&/|map (partial compile-annotation =method) ?anns) - _ (doto =method - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0))] + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) - :let [_ (doto =method - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig))] + :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) @@ -551,6 +617,7 @@ (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) @@ -571,6 +638,7 @@ (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) @@ -592,6 +660,7 @@ (|do [^MethodVisitor =method &/get-writer :let [_ (&/|map (partial compile-annotation =method) ?anns) _ (.visitCode =method)] + =input-tags (prepare-method-inputs 0 ?inputs =method) _ (compile ?body) :let [_ (doto =method (compile-method-return ?output) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 90b1f2bf1..cd41b4be7 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -31,6 +31,7 @@ ;; [Utils] (defn ^:private escape-char [escaped] + "(-> Text (Lux Text))" (cond (.equals ^Object escaped "\\t") (return "\t") (.equals ^Object escaped "\\b") (return "\b") (.equals ^Object escaped "\\n") (return "\n") @@ -42,6 +43,18 @@ (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private escape-char* [escaped] + "(-> Text Text)" + ;; (prn 'escape-char* + ;; escaped + ;; (cond (.equals ^Object escaped "\\t") "\t" + ;; (.equals ^Object escaped "\\b") "\b" + ;; (.equals ^Object escaped "\\n") "\n" + ;; (.equals ^Object escaped "\\r") "\r" + ;; (.equals ^Object escaped "\\f") "\f" + ;; (.equals ^Object escaped "\\\"") "\"" + ;; (.equals ^Object escaped "\\\\") "\\" + ;; :else + ;; (assert false (str "[Lexer Error] Unknown escape character: " escaped)))) (cond (.equals ^Object escaped "\\t") "\t" (.equals ^Object escaped "\\b") "\b" (.equals ^Object escaped "\\n") "\n" @@ -52,39 +65,78 @@ :else (assert false (str "[Lexer Error] Unknown escape character: " escaped)))) -(defn ^:private escape-unicode [unicode] +(defn ^:private escape-unicode [^String unicode] + "(-> Text Text)" (str (char (Integer/valueOf (.substring unicode 2) 16)))) -(defn ^:private clean-line [raw-line] - (-> raw-line - (string/replace #"\\u[0-9a-fA-F]{4}" escape-unicode) - (string/replace #"\\." escape-char*))) +(defn ^:private clean-line [^String raw-line] + "(-> Text Text)" + (let [line-length (.length raw-line) + buffer (new StringBuffer line-length)] + (loop [idx 0] + (if (< idx line-length) + (let [current-char (.charAt raw-line idx)] + (if (= \\ current-char) + (do (assert (< (+ 1 idx) line-length) (str "[Lexer] Text is too short for escaping: " raw-line " " idx)) + (case (.charAt raw-line (+ 1 idx)) + \t (do (.append buffer "\t") + (recur (+ 2 idx))) + \b (do (.append buffer "\b") + (recur (+ 2 idx))) + \n (do (.append buffer "\n") + (recur (+ 2 idx))) + \r (do (.append buffer "\r") + (recur (+ 2 idx))) + \f (do (.append buffer "\f") + (recur (+ 2 idx))) + \" (do (.append buffer "\"") + (recur (+ 2 idx))) + \\ (do (.append buffer "\\") + (recur (+ 2 idx))) + \u (do (assert (< (+ 5 idx) line-length) (str "[Lexer] Text is too short for unicode-escaping: " raw-line " " idx)) + (.append buffer (char (Integer/valueOf (.substring raw-line (+ 2 idx) (+ 6 idx)) 16))) + (recur (+ 6 idx))) + ;; else + (assert false (str "[Lexer] Invalid escaping syntax: " raw-line " " idx)))) + (do (.append buffer current-char) + (recur (+ 1 idx))))) + (.toString buffer)))) + ;; (-> raw-line + ;; (string/replace #"\\u[0-9a-fA-F]{4}" escape-unicode) + ;; (string/replace #"\\." escape-char*)) + ) (defn ^:private lex-text-body [offset] - (|do [[_ eol? ^String pre-quotes] (&reader/read-regex #"^([^\"]*)") - post-quotes (if (.endsWith pre-quotes "\\") - (if eol? - (fail "[Lexer Error] Can't leave dangling back-slash \\") - (if (if-let [^String back-slashes (re-find #"\\+$" pre-quotes)] - (odd? (.length back-slashes))) - (|do [_ (&reader/read-regex #"^([\"])") - next-part (lex-text-body offset)] - (return (str "\"" next-part))) - (lex-text-body offset))) - (if eol? - (|do [[_ _ ^String line-prefix] (&reader/read-regex #"^( +|$)") - :let [empty-line? (= "" line-prefix)] - _ (&/assert! (or empty-line? - (>= (.length line-prefix) offset)) - "Each line of a multi-line text must have an appropriate offset!") - next-part (lex-text-body offset)] - (return (str "\n" - (if empty-line? - "" - (.substring line-prefix offset)) - next-part))) - (return "")))] - (return (clean-line (str pre-quotes post-quotes))))) + (|do [[_ eol? ^String pre-quotes*] (&reader/read-regex #"^([^\"]*)") + [pre-quotes post-quotes] (if (.endsWith pre-quotes* "\\") + (if eol? + (fail "[Lexer Error] Can't leave dangling back-slash \\") + (if (if-let [^String back-slashes (re-find #"\\+$" pre-quotes*)] + (odd? (.length back-slashes))) + (|do [_ (&reader/read-regex #"^([\"])") + next-part (lex-text-body offset)] + (return (&/T [(.substring pre-quotes* 0 (dec (.length pre-quotes*))) + (str "\"" next-part)]))) + (|do [post-quotes* (lex-text-body offset)] + (return (&/T [pre-quotes* post-quotes*]))))) + (if eol? + (|do [[_ _ ^String line-prefix] (&reader/read-regex #"^( +|$)") + :let [empty-line? (= "" line-prefix)] + _ (&/assert! (or empty-line? + (>= (.length line-prefix) offset)) + "Each line of a multi-line text must have an appropriate offset!") + next-part (lex-text-body offset)] + (return (&/T [pre-quotes* + (str "\n" + (if empty-line? + "" + (.substring line-prefix offset)) + next-part)]))) + (return (&/T [pre-quotes* ""])))) + :let [cleaned (str (clean-line pre-quotes) post-quotes) + ;; _ (println 'cleaned cleaned) + ]] + (return cleaned))) (def ^:private lex-text (|do [[meta _ _] (&reader/read-text "\"") diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj index f01212b70..61baecce3 100644 --- a/src/lux/packager/program.clj +++ b/src/lux/packager/program.clj @@ -103,12 +103,10 @@ (let [entry-name (.getName entry)] (if (and (not (.isDirectory entry)) (not (.startsWith entry-name "META-INF/maven/")) - ;; (.endsWith entry-name ".class") (not (contains? seen entry-name))) - (let [;; _ (prn 'entry entry-name) - entry-data (read-stream is)] + (let [entry-data (read-stream is)] (doto out - (.putNextEntry entry) + (.putNextEntry (doto entry (.setCompressedSize -1))) (.write entry-data 0 (alength entry-data)) (.flush) (.closeEntry)) @@ -123,13 +121,16 @@ (defn package [module] "(-> Text Null)" (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] - (doseq [$group (.listFiles (new File &&/output-dir))] - (write-module! $group out)) - (write-resources! out) - (->> (fetch-available-jars) - (filter #(and (not (.endsWith ^String % "luxc.jar")) - (not (.endsWith ^String % "tools.nrepl-0.2.3.jar")) - (not (.endsWith ^String % "clojure-complete-0.2.3.jar")))) - (reduce (fn [s ^String j] (add-jar! (new File ^String j) s out)) - #{"META-INF/MANIFEST.MF"})) + (do (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + (write-resources! out) + (->> (fetch-available-jars) + (filter #(and (not (.endsWith ^String % "luxc.jar")) + (not (.endsWith ^String % "tools.nrepl-0.2.3.jar")) + (not (.endsWith ^String % "clojure-complete-0.2.3.jar")) + (not (.endsWith ^String % "clojure-1.6.0.jar")) + (not (.endsWith ^String % "core.match-0.2.1.jar")))) + (reduce (fn [s ^String j] (add-jar! (new File ^String j) s out)) + #{"META-INF/MANIFEST.MF"})) + nil) )) -- cgit v1.2.3