aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser/host.clj6
-rw-r--r--src/lux/analyser/lux.clj27
-rw-r--r--src/lux/base.clj4
-rw-r--r--src/lux/compiler/host.clj79
-rw-r--r--src/lux/lexer.clj110
-rw-r--r--src/lux/packager/program.clj27
6 files changed, 193 insertions, 60 deletions
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)
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 01:12:28 +0000