aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux.clj1
-rw-r--r--src/lux/analyser.clj106
-rw-r--r--src/lux/compiler.clj43
3 files changed, 98 insertions, 52 deletions
diff --git a/src/lux.clj b/src/lux.clj
index f748fd0f3..6d2374edb 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -23,7 +23,6 @@
;; TODO: Reinplement "if" as a macro on top of case.
;; TODO: Remember to optimized calling global functions.
;; TODO: Reader macros.
- ;; TODO: Automatic currying of functions.
;; TODO:
;; TODO:
;; TODO:
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index d44c333b1..8fd6dfb47 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -305,7 +305,7 @@
(reduce (fn [tail x]
(doto (.newInstance (.loadClass loader "lux.Variant2"))
(-> .-tag (set! "Cons"))
- (-> .-_1 (set! (->lux x)))
+ (-> .-_1 (set! (->lux loader x)))
(-> .-_2 (set! tail))))
(doto (.newInstance (.loadClass loader "lux.Variant0"))
(-> .-tag (set! "Nil")))
@@ -354,6 +354,7 @@
(def ^:private ->lux+ (partial ->lux+* ->lux))
(defn ->clojure+* [->clojure xs]
+ (prn '->clojure+* (.-tag xs))
(case (.-tag xs)
"Nil" '()
"Cons" (cons (->clojure (.-_1 xs))
@@ -361,21 +362,23 @@
))
(defn ->clojure [x]
+ (pr '->clojure (.-tag x))
(case (.-tag x)
- "Bool" [::&parser/bool (-> x .-_1)]
- "Int" [::&parser/int (-> x .-_1)]
- "Real" [::&parser/real (-> x .-_1)]
- "Char" [::&parser/char (-> x .-_1)]
- "Text" [::&parser/text (-> x .-_1)]
- "Tag" [::&parser/tag (-> x .-_1)]
- "Ident" [::&parser/ident (-> x .-_1)]
- "Tuple" [::&parser/tuple (->> x .-_1 (->clojure+* ->clojure))]
- "Form" [::&parser/form (->> x .-_1 (->clojure+* ->clojure))]))
+ "Bool" (do (println) [::&parser/bool (.-_1 x)])
+ "Int" (do (println) [::&parser/int (.-_1 x)])
+ "Real" (do (println) [::&parser/real (.-_1 x)])
+ "Char" (do (println) [::&parser/char (.-_1 x)])
+ "Text" (do (println) [::&parser/text (.-_1 x)])
+ "Tag" (do (println " " (.-_1 x)) [::&parser/tag (.-_1 x)])
+ "Ident" (do (println) [::&parser/ident (.-_1 x)])
+ "Tuple" (do (println) [::&parser/tuple (->clojure+* ->clojure (.-_1 x))])
+ "Form" (do (println) [::&parser/form (->clojure+* ->clojure (.-_1 x))])))
(def ^:private ->clojure+ (partial ->clojure+* ->clojure))
(defn ^:private analyse-tuple [analyse-ast ?elems]
- (exec [=elems (do-all-m* (map analyse-ast ?elems))]
+ (exec [=elems (do-all-m* (map analyse-ast ?elems))
+ :let [_ (prn 'analyse-tuple =elems)]]
(return (list (annotated [::tuple =elems] [::&type/tuple (mapv :type =elems)])))))
(defn ^:private analyse-ident [analyse-ast ?ident]
@@ -388,12 +391,19 @@
[::global-fn ?module ?name]
(exec [macro? (is-macro? ?module ?name)]
(if macro?
- (let [macro-class (str ?module "$" (normalize-ident ?name))]
- (-> (.loadClass loader macro-class)
- .newInstance
- (.apply (->lux+ loader ?args))
- ->clojure
- analyse-ast))
+ (let [macro-class (str ?module "$" (normalize-ident ?name))
+ output (-> (.loadClass loader macro-class)
+ .getDeclaredConstructors
+ first
+ (.newInstance (to-array [(int 0) nil]))
+ (.apply (->lux+ loader ?args))
+ (.apply nil))
+ _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output)))
+ macro-expansion (->clojure+ (.-_1 output))
+ state* (.-_2 output)
+ _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion)
+ ]
+ (do-all-m* (map analyse-ast macro-expansion)))
(exec [=args (do-all-m* (map analyse-ast ?args))
:let [[needs-num =return-type] (match (:type =fn)
[::&type/function ?fargs ?freturn]
@@ -654,17 +664,35 @@
(exec [[=value] (analyse-ast ?value)
idx next-local-idx
[=body] (with-let ?label (:type =value)
- (analyse-ast ?body))]
+ (analyse-ast ?body))
+ :let [_ (prn 'analyse-let =body)]]
(return (list (annotated [::let idx ?label =value =body] (:type =body))))))
-(defn ^:private raise-tree-bindings [raise-expr outer-scope ?tree]
- (let [partial-f (partial raise-expr outer-scope)
- tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+(defn ^:private raise-tree-bindings [raise-expr outer-scope offset ?tree]
+ (let [partial-f (partial raise-expr outer-scope offset)
+ tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)]
(case (:type ?tree)
+ ::tuple*
+ (-> ?tree
+ (update-in [:patterns]
+ #(into {} (for [[?tag ?unapply] %]
+ [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+ (update-in [:default]
+ (fn [[tag local $branch :as total]]
+ ;; (prn 'total total)
+ (if total
+ [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch]))))
+
::adt*
- (update-in ?tree [:patterns]
- #(into {} (for [[?tag ?unapply] %]
- [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+ (-> ?tree
+ (update-in [:patterns]
+ #(into {} (for [[?tag ?unapply] %]
+ [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+ (update-in [:default]
+ (fn [[tag local $branch :as total]]
+ ;; (prn 'total total)
+ (if total
+ [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch]))))
::defaults
(update-in ?tree [:stores]
@@ -675,10 +703,10 @@
(assert false (pr-str ?tree))
)))
-(defn ^:private raise-expr [outer-scope syntax]
+(defn ^:private raise-expr [outer-scope offset syntax]
;; (prn 'raise-bindings body)
- (let [partial-f (partial raise-expr outer-scope)
- tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+ (let [partial-f (partial raise-expr outer-scope offset)
+ tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)]
(match (:form syntax)
[::literal ?value]
syntax
@@ -702,20 +730,24 @@
{:form [::self outer-scope (mapv partial-f ?curried)]
:type (:type syntax)}
+ [::global _ _]
+ syntax
+
[::jvm:iadd ?x ?y]
{:form [::jvm:iadd (partial-f ?x) (partial-f ?y)]
:type (:type syntax)}
[::let ?idx ?name ?value ?body]
- {:form [::let ?idx ?name (partial-f ?value) (partial-f ?body)]
+ {:form [::let offset ?name (partial-f ?value)
+ (raise-expr outer-scope (inc offset) ?body)]
:type (:type syntax)}
[::case ?base ?variant ?registers ?mappings ?tree]
(let [=variant (partial-f ?variant)
=mappings (into {} (for [[idx syntax] ?mappings]
- [idx (partial-f syntax)]))
+ [idx (raise-expr outer-scope (+ offset ?registers) syntax)]))
=tree (tree-partial-f ?tree)]
- {:form [::case ?base =variant ?registers =mappings =tree]
+ {:form [::case offset =variant ?registers =mappings =tree]
:type (:type syntax)})
[::lambda ?scope ?captured ?args ?value]
@@ -748,7 +780,7 @@
:let [;; _ (prn '(:form =body) (:form =body))
=lambda (match (:form =body)
[::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body]
- [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope ?sub-body)]
+ [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope (-> ?sub-args count (+ 2)) ?sub-body)]
_
[::lambda =scope =captured (list ?arg) =body])]
@@ -757,6 +789,7 @@
(return (list (annotated =lambda =function)))))
(defn ^:private analyse-def [analyse-ast ?name ?value]
+ ;; (prn 'analyse-def ?name ?value)
(exec [def?? (defined? ?name)]
(if def??
(fail (str "Can't redefine function/constant: " ?name))
@@ -769,12 +802,12 @@
new-scope [$module ?name]
=value (match (:form =value)
[::lambda ?old-scope ?env ?args ?body]
- {:form [::lambda new-scope ?env ?args (raise-expr new-scope ?body)]
+ {:form [::lambda new-scope ?env ?args (raise-expr new-scope (-> ?args count inc) ?body)]
:type (:type =value)}
_
=value)]
- ;; :let [_ (prn 'DEF/POST =value)]
+ ;; :let [_ (prn 'DEF/POST ?name =value)]
_ (if ann??
(return nil)
(annotate ?name ::constant ::public false (:type =value)))
@@ -886,7 +919,7 @@
(return (list (annotated [::literal ?value] [::&type/object "java.lang.String" []])))
[::&parser/tag ?tag]
- (do (prn 'analyse-basic-ast/variant0 ?tag)
+ (do ;; (prn 'analyse-basic-ast/variant0 ?tag)
(return (list (annotated [::variant ?tag '()] [::&type/variant ?tag '()]))))
[::&parser/tuple ?elems]
@@ -898,7 +931,7 @@
[::&parser/form ([[::&parser/ident "if"] ?test ?then ?else] :seq)]
(analyse-if analyse-ast ?test ?then ?else)
- [::&parser/form ([[::&parser/ident "let"] [::&parser/ident ?label] ?value ?body] :seq)]
+ [::&parser/form ([[::&parser/ident "let'"] [::&parser/ident ?label] ?value ?body] :seq)]
(analyse-let analyse-ast ?label ?value ?body)
[::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)]
@@ -967,7 +1000,8 @@
(match token
[::&parser/form ([[::&parser/tag ?tag] & ?data] :seq)]
(exec [=data (do-all-m* (map analyse-ast ?data))
- :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)]]
+ ;; :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)]
+ ]
(return (list (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)]))))
[::&parser/form ([?fn & ?args] :seq)]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index f6daaca0f..76f480a14 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -605,6 +605,7 @@
(.visitInsn Opcodes/DUP)
(.visitLabel start-label))
default-label (new Label)
+ ;; _ (prn '?decision-tree ?decision-tree)
_ (do (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))]
(if (or (:default ?decision-tree)
(not (empty? (:defaults ?decision-tree))))
@@ -693,7 +694,7 @@
(let [num-args (count args)]
(str "(" (reduce str "" (repeat (count closed-over) clo-field-sig))
(if (> num-args 1)
- (reduce str counter-sig (repeat num-args clo-field-sig)))
+ (reduce str counter-sig (repeat (dec num-args) clo-field-sig)))
")"
<init>-return)))
@@ -728,6 +729,22 @@
(.visitMaxs 0 0)
(.visitEnd))))
+ (defn add-closed-over-vars [writer class-name closed-over]
+ (dotimes [capt_idx (count closed-over)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig))))
+
+ (defn add-partial-vars [writer class-name args]
+ (dotimes [clo_idx (count args)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig))))
+
+ (defn add-nulls [writer amount]
+ (dotimes [_ amount]
+ (.visitInsn writer Opcodes/ACONST_NULL)))
+
(defn add-lambda-apply [class class-name closed-over args impl-signature init-signature]
(let [num-args (count args)
num-captured (dec num-args)
@@ -736,31 +753,24 @@
(new Label))]
(doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil)
(.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig)
(.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
(-> (doto (.visitLabel branch-label)
(.visitTypeInsn Opcodes/NEW class-name)
(.visitInsn Opcodes/DUP)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig))
- (->> (dotimes [capt_idx (count closed-over)])))
+ (add-closed-over-vars class-name closed-over)
(.visitLdcInsn (-> current-captured inc int))
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx current-captured])))
+ (add-partial-vars class-name (take current-captured args))
(.visitVarInsn Opcodes/ALOAD 1)
- (-> (.visitInsn Opcodes/ACONST_NULL)
- (->> (dotimes [clo_idx (- (dec num-captured) current-captured)])))
+ (add-nulls (- (dec num-captured) current-captured))
(.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature)
(.visitInsn Opcodes/ARETURN))
(->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))])))
- (.visitLabel default-label)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx num-captured]))))
+ (.visitLabel default-label))
(->> (when (> num-args 1))))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (add-partial-vars class-name (butlast args))
(.visitVarInsn Opcodes/ALOAD 1)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature)
(.visitInsn Opcodes/ARETURN)
@@ -1066,7 +1076,9 @@
))
;; [Interface]
-(let [compiler-step (exec [analysis+ &analyser/analyse]
+(let [compiler-step (exec [analysis+ &analyser/analyse
+ ;; :let [_ (prn 'analysis+ analysis+)]
+ ]
(map-m compile analysis+))]
(defn compile-module [name]
(exec [loader &util/loader]
@@ -1090,6 +1102,7 @@
(fail* ?message))))))))
(defn compile-all [modules]
+ (.mkdir (java.io.File. "output"))
(let [state {::&lexer/source nil
::&analyser/current-module nil
::&analyser/scope []
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 07:37:56 +0000