[Working on]

- The monadic implementation of macros is almost done.
	- Missing error-handling.
[Fixes]
- The output folder is now generated on each compiler run to avoid exceptions thrown by the class-loader.

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 []