Almost finished implementing closures.

2 files changed, 133 insertions, 50 deletions

diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index bc48a0c81..109ba15f6 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -16,6 +16,12 @@
   {:form form
    :type type})
 
+(defn ^:private fresh-env [id]
+  {:id id
+   :counter 0
+   :mappings {}
+   :closure/id 0})
+
 (def ^:private module-name
   (fn [state]
     [::&util/ok [state (:name state)]]))
@@ -24,42 +30,52 @@
   (fn [state]
     [::&util/ok [(-> state
                      (assoc-in [:defs (:name state) name] desc)
-                     (assoc-in [:env :mappings name] (annotated [::global (:name state) name] (:type desc)))) nil]]))
+                     (assoc-in [:defs-env name] (annotated [::global (:name state) name] (:type desc))))
+                 nil]]))
 
 (def ^:private next-local-idx
   (fn [state]
-    [::&util/ok [state (-> state :env :counter)]]))
+    [::&util/ok [state (-> state :env first :counter)]]))
+
+(def ^:private my-frame
+  (fn [state]
+    [::&util/ok [state (-> state :env first)]]))
 
 (defn ^:private with-local [name type body]
   (fn [state]
-    (let [=return (body (update-in state [:env] #(-> %
-                                                     (update-in [:counter] inc)
-                                                     (assoc-in [:mappings name] (annotated [::local (:counter %)] type)))))]
+    (let [=return (body (update-in state [:env]
+                                   #(cons (-> (first %)
+                                              (update-in [:counter] inc)
+                                              (assoc-in [:mappings name] (annotated [::local (:id (first %)) (:counter (first %))] type)))
+                                          (rest %))))]
+      ;; =return
       (match =return
         [::&util/ok [?state ?value]]
-        [::&util/ok [(assoc ?state :env (:env state)) ?value]]
+        (do (prn 'POST-WITH-LOCAL name (-> ?state :env first))
+          [::&util/ok [(update-in ?state [:env] #(cons (-> (first %)
+                                                           (update-in [:counter] dec)
+                                                           (update-in [:mappings] dissoc name))
+                                                       (rest %)))
+                       ;; (update-in ?state [:env] (fn [[top & oframes]]
+                       ;;                            (prn 'NEW-FRAMES name (cons (-> state :env first (assoc :closure (-> top :closure))) oframes))
+                       ;;                            (cons (-> state :env first (assoc :closure (-> top :closure))) oframes)))
+                       ?value]])
         
         _
-        =return))))
+        =return)
+      )))
 
 (defn ^:private with-fresh-env [body]
   (fn [state]
-    (let [=return (body (update-in state [:env]
-                                   #(-> %
-                                        (assoc :counter 0)
-                                        (update-in [:mappings] (fn [ms]
-                                                                 (let [ms* (into {} (for [[k v] ms
-                                                                                          :when (match (:form v)
-                                                                                                  [::local _]
-                                                                                                  false
-                                                                                                  _
-                                                                                                  true)]
-                                                                                      [k v]))]
-                                                                   ;; (prn 'ms ms 'ms* ms*)
-                                                                   ms*))))))]
+    ;; (prn '(:env state) (:env state) (-> state :env first :id inc))
+    (let [=return (body (update-in state [:env] #(conj % (fresh-env (-> % first :id inc)))))
+          ;; _ (prn '=return =return)
+          ]
       (match =return
         [::&util/ok [?state ?value]]
-        [::&util/ok [(assoc ?state :env (:env state)) ?value]]
+        (do (prn 'PRE-LAMBDA (:env state))
+          (prn 'POST-LAMBDA (:env ?state) ?value)
+          [::&util/ok [(assoc ?state :env (:env state)) [(-> ?state :env first) ?value]]])
         
         _
         =return))))
@@ -67,8 +83,8 @@
 (defn ^:private import-class [long-name short-name]
   (fn [state]
     (let [=class (annotated [::class long-name] ::&type/nothing)]
-      [::&util/ok [(update-in state [:env :mappings] merge {long-name =class,
-                                                            short-name =class})
+      [::&util/ok [(update-in state [:imports] merge {long-name =class,
+                                                      short-name =class})
                    nil]])))
 
 (defn ^:private require-module [name alias]
@@ -76,15 +92,42 @@
     [::&util/ok [(assoc-in state [:deps alias] name)
                  nil]]))
 
+(defn ^:private close-over [ident register frame]
+  (prn 'close-over ident register)
+  (let [register* (annotated [::captured (:id frame) (:closure/id frame) register] (:type register))]
+    [register* (-> frame
+                   (update-in [:closure/id] inc)
+                   (assoc-in [:mappings ident] register*))]))
+
 (defn ^:private resolve [ident]
   (fn [state]
     (if-let [[_ ?alias ?binding] (re-find #"^(.*)/(.*)$" ident)]
       (let [?module (get-in state [:deps ?alias])]
         ;; (prn 'resolve ?module ?alias ?binding)
         [::&util/ok [state (annotated [::global ?module ?binding] ::&type/nothing)]])
-      (if-let [resolved (get-in state [:env :mappings ident])]
-        [::&util/ok [state resolved]]
-        [::&util/failure (str "Unresolved identifier: " ident)]))))
+      (let [_ (prn 'resolve/_1 ident)
+            [inner outer] (split-with #(nil? (get-in % [:mappings ident])) (:env state))
+            ;; _ (prn ident '[inner outer] [inner outer])
+            _ (prn 'resolve/_2 '[inner outer] [inner outer])]
+        (cond (empty? inner)
+              [::&util/ok [state (-> state :env first :mappings (get ident))]]
+              
+              (empty? outer)
+              (if-let [global|import (or (get-in state [:defs-env ident])
+                                         (get-in state [:imports ident]))]
+                (do (prn 'resolve/_3 'global|import global|import)
+                  [::&util/ok [state global|import]])
+                [::&util/failure (str "Unresolved identifier: " ident)])
+
+              :else
+              (let [[=local inner*] (reduce (fn [[register new-inner] frame]
+                                              (let [[register* frame*] (close-over ident register frame)]
+                                                [register* (cons frame* new-inner)]))
+                                            [(-> outer first :mappings (get ident)) '()]
+                                            (reverse inner))
+                    _ (prn 'resolve/_4 '[=local inner*] =local inner*)]
+                [::&util/ok [(assoc state :env (concat inner* outer)) =local]])))
+      )))
 
 (defmacro ^:private defanalyser [name match return]
   `(def ~name
@@ -136,10 +179,13 @@
 
 (defanalyser analyse-ident
   [::&parser/ident ?ident]
-  (exec [_env (fn [state] [::&util/ok [state (:env state)]])
-         ;; :let [_ (prn 'analyse-ident ?ident _env)]
-         ]
-    (resolve ?ident)))
+  ;; (exec [_env (fn [state] [::&util/ok [state (:env state)]])
+  ;;        ;; :let [_ (prn 'analyse-ident ?ident _env)]
+  ;;        ]
+  ;;   (resolve ?ident))
+  (exec [=ident (resolve ?ident)
+         :let [_ (prn 'analyse-ident ?ident =ident)]]
+    (return =ident)))
 
 (defanalyser analyse-ann-class
   [::&parser/ann-class ?class ?members]
@@ -277,19 +323,22 @@
          [=function =args =return] (within :types (&type/fresh-function (count ?args)))
          ;; :let [_ (prn '[=function =args =return] [=function =args =return])]
          ;; :let [_ (prn 'PRE/?body ?body)]
-         _env (fn [state] [::&util/ok [state (:env state)]])
+         ;; _env (fn [state] [::&util/ok [state (:env state)]])
          ;; :let [_ (prn 'analyse-lambda _env)]
-         =body (with-fresh-env
-                 (reduce (fn [inner [label type]]
-                           (with-local label type inner))
-                         (analyse-form* ?body)
-                         (reverse (map vector ?args =args))))
+         [=frame =body] (with-fresh-env
+                          (reduce (fn [inner [label type]]
+                                    (exec [=inner (with-local label type inner)
+                                           =frame* my-frame
+                                           :let [_ (prn '=frame* =frame*)]]
+                                      (return =inner)))
+                                  (analyse-form* ?body)
+                                  (reverse (map vector ?args =args))))
          ;; :let [_ (prn '=body =body)]
          =function (within :types (exec [_ (&type/solve =return (:type =body))]
                                     (&type/clean =function)))
          ;; :let [_ (prn '=function =function)]
          ]
-    (return (annotated [::lambda ?args =body] =function))))
+    (return (annotated [::lambda =frame ?args =body] =function))))
 
 (defanalyser analyse-import
   [::&parser/import ?class]
@@ -334,8 +383,10 @@
   (match ((repeat-m analyse-form) {:name module-name,
                                    :forms tokens
                                    :deps {}
-                                   :env {:counter 0
-                                         :mappings {}}
+                                   :imports {}
+                                   :defs {}
+                                   :defs-env {}
+                                   :env (list (fresh-env 0))
                                    :types &type/+init+})
     [::&util/ok [?state ?forms]]
     (if (empty? (:forms ?state))
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index 9de072bc0..f2c57f410 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -118,11 +118,18 @@
         (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" idx) "Ljava/lang/Object;")))))
 
 (defcompiler ^:private compile-local
-  [::&analyser/local ?idx]
-  (do ;; (prn 'LOCAL ?idx)
+  [::&analyser/local ?env ?idx]
+  (do (prn 'LOCAL ?idx)
       (doto *writer*
         (.visitVarInsn Opcodes/ALOAD (int ?idx)))))
 
+(defcompiler ^:private compile-captured
+  [::&analyser/captured ?closure-id ?captured-id ?source]
+  (do (prn 'CAPTURED [?closure-id ?captured-id])
+    (doto *writer*
+      (.visitVarInsn Opcodes/ALOAD 0)
+      (.visitFieldInsn Opcodes/GETFIELD (str "test2" "$" "lambda") (str "__" (inc ?captured-id)) "Ljava/lang/Object;"))))
+
 (defcompiler ^:private compile-global
   [::&analyser/global ?owner-class ?name]
   (do ;; (prn 'GLOBAL ?owner-class ?name *type*)
@@ -408,8 +415,9 @@
         )))
 
 (defcompiler ^:private compile-lambda
-  [::&analyser/lambda ?args ?body]
-  (let [num-args (count ?args)
+  [::&analyser/lambda ?frame ?args ?body]
+  (let [_ (prn '?frame ?frame)
+        num-args (count ?args)
         outer-class (->class *class-name*)
         clo-field-sig (->type-signature "java.lang.Object")
         counter-sig "I"
@@ -418,7 +426,9 @@
         current-class (str outer-class "$" "lambda")
         num-captured (dec num-args)
         init-signature (if (not= 0 num-captured)
-                         (str "(" (apply str counter-sig (repeat num-captured clo-field-sig)) ")" "V")
+                         (str "(" (apply str (repeat (count (:mappings ?frame)) clo-field-sig))
+                              counter-sig
+                              (apply str (repeat num-captured clo-field-sig)) ")" "V")
                          (str "()" "V"))]
     ;; (.visitInnerClass *parent* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
     (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
@@ -431,16 +441,27 @@
                   (.visitCode)
                   (.visitVarInsn Opcodes/ALOAD 0)
                   (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
-                  (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
-                        (.visitVarInsn Opcodes/ILOAD 1)
+                  (-> (doto (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+                                  (.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
+                                  (.visitFieldInsn Opcodes/PUTFIELD current-class captured-name clo-field-sig))
+                                (do (doto =class
+                                      (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
+                                      (.visitEnd)))
+                                (->> (let [captured-name (str "__" (inc ?captured-id))])
+                                     (match (:form ?captured)
+                                       [::&analyser/captured ?closure-id ?captured-id ?source])
+                                     (doseq [[?name ?captured] (:mappings ?frame)])))
+                        (.visitVarInsn Opcodes/ALOAD 0)
+                        (.visitVarInsn Opcodes/ILOAD (inc (count (:mappings ?frame))))
                         (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig)
                         (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
-                              (.visitVarInsn Opcodes/ALOAD (+ clo_idx 2))
+                              (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset))
                               (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
                             (->> (let [field-name (str "_" clo_idx)]
                                    (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
                                      (.visitEnd)))
-                                 (dotimes [clo_idx num-captured]))))
+                                 (dotimes [clo_idx num-captured])
+                                 (let [offset (+ 2 (count (:mappings ?frame)))]))))
                       (->> (when (not= 0 num-captured))))
                   (.visitInsn Opcodes/RETURN)
                   (.visitMaxs 0 0)
@@ -450,12 +471,16 @@
                                         (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 current-class "_counter" counter-sig)
                             (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
                             (-> (doto (.visitLabel branch-label)
                                   (.visitTypeInsn Opcodes/NEW current-class)
                                   (.visitInsn Opcodes/DUP)
+                                  (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+                                        (.visitFieldInsn Opcodes/GETFIELD current-class (str "__" (inc capt_idx)) clo-field-sig))
+                                      (->> (dotimes [capt_idx (count (:mappings ?frame))])))
                                   (.visitVarInsn Opcodes/ALOAD 0)
                                   (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
                                   (.visitInsn Opcodes/ICONST_1)
@@ -478,12 +503,14 @@
                                 (->> (dotimes [clo_idx num-captured]))))
                           (->> (when (not= 0 num-captured))))
                       (.visitVarInsn Opcodes/ALOAD 1)
-                      (.visitMethodInsn Opcodes/INVOKESTATIC current-class "impl" real-signature)
+                      (.visitMethodInsn Opcodes/INVOKEVIRTUAL current-class "impl" real-signature)
                       ;; (.visitLabel end-label)
                       (.visitInsn Opcodes/ARETURN)
                       (.visitMaxs 0 0)
                       (.visitEnd)))
-          =impl (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "impl" real-signature nil nil)
+          _ (prn 'LAMBDA/?body ?body)
+          =impl (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC ;; Opcodes/ACC_STATIC
+                                              ) "impl" real-signature nil nil)
                   (.visitCode)
                   (->> (assoc *state* :form ?body :writer)
                        compile-form)
@@ -495,6 +522,10 @@
     (doto *writer*
       (.visitTypeInsn Opcodes/NEW current-class)
       (.visitInsn Opcodes/DUP)
+      (-> (do (compile-form (assoc *state* :form ?source)))
+          (->> (match (:form ?captured)
+                 [::&analyser/captured ?closure-id ?captured-id ?source])
+               (doseq [[?name ?captured] (:mappings ?frame)])))
       (-> (doto (.visitInsn Opcodes/ICONST_0)
             ;; (.visitInsn Opcodes/ICONST_0)
             (-> (.visitInsn Opcodes/ACONST_NULL)
@@ -581,6 +612,7 @@
                    compile-variant
                    compile-tuple
                    compile-local
+                   compile-captured
                    compile-global
                    compile-call
                    compile-static-access