Added lambdas! (not yet real closures, but coming soon...)

7 files changed, 198 insertions, 29 deletions

diff --git a/.gitignore b/.gitignore
index e04714ba8..fdc7212fc 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,3 +7,6 @@ pom.xml.asc
 *.class
 /.lein-*
 /.nrepl-port
+LICENSE
+README.md
+doc/intro.md
diff --git a/src/lang.clj b/src/lang.clj
index c497c9923..0bbd74bf6 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -11,25 +11,29 @@
     (.write stream data)))
 
 (comment
-  ;; TODO: Add lambdas.
   ;; TODO: Add pattern-matching.
-  ;; TODO: Add thunks.
-  ;; TODO: Add Java-interop.
-  ;; TODO: Do tail-call optimization.
-  ;; TODO: Add macros.
-  ;; TODO: Add signatures & structures OR type-classes.
-  ;; TODO: Add type-level computations.
-  ;; TODO: Add interpreter.
-  ;; TODO: Re-implement compiler in language.
+  ;; TODO: Add "do" expressions.
   ;; TODO: Add all the missing literal types.
   ;; TODO: Allow strings to have escape characters.
-  ;; TODO: Add "do" expressions.
   ;; TODO: Fold all closure classes into one.
   ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly.
   ;; TODO: Add extra arities (apply2, apply3, ..., apply16)
+  ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples).
+  ;; TODO: Allow "lambdas" to be closures.
+  ;; TODO: Add Java-interop.
+  ;; TODO: Add interpreter.
+  ;; TODO: Add macros.
+  ;; TODO: Re-implement compiler in language.
+  ;; TODO: Add signatures & structures OR type-classes.
+  ;; TODO: Add type-level computations.
+  ;; TODO: Add thunks.
+  ;; TODO: Do tail-call optimization.
+  ;; TODO: Adding metadata to global vars.
+  ;; TODO: Add records.
   ;; TODO: 
   ;; TODO: 
-
+  ;; TODO: 
+  
   (let [source-code (slurp "test2.lang")
         tokens (&lexer/lex source-code)
         ;; _ (prn 'tokens tokens)
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 122d6353d..d00fb7319 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -41,6 +41,28 @@
         _
         =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*))))))]
+      (match =return
+        [::&util/ok [?state ?value]]
+        [::&util/ok [(assoc ?state :env (:env state)) ?value]]
+        
+        _
+        =return))))
+
 (defn ^:private import-class [long-name short-name]
   (fn [state]
     (let [=class (annotated [::class long-name] ::&type/nothing)]
@@ -73,6 +95,7 @@
          (fail* (str "Unmatched token: " token#))))))
 
 (defn analyse-form* [form]
+  (prn 'analyse-form* form)
   (fn [state]
     (let [old-forms (:forms state)
           =return (analyse-form (assoc state :forms (list form)))]
@@ -103,7 +126,9 @@
 
 (defanalyser analyse-ident
   [::&parser/ident ?ident]
-  (resolve ?ident))
+  (exec [_env (fn [state] [::&util/ok [state (:env state)]])
+         :let [_ (prn 'analyse-ident ?ident _env)]]
+    (resolve ?ident)))
 
 (defanalyser analyse-ann-class
   [::&parser/ann-class ?class ?members]
@@ -127,15 +152,22 @@
 
 (defanalyser analyse-fn-call
   [::&parser/fn-call ?fn ?args]
-  (exec [=fn (analyse-form* ?fn)
-         =args (map-m analyse-form* ?args)]
-    (return (annotated [::call =fn =args] ::&type/nothing))))
+  (exec [:let [_ (prn 'PRE '?fn ?fn)]
+         =fn (analyse-form* ?fn)
+         :let [_ (prn '=fn =fn)]
+         =args (map-m analyse-form* ?args)
+         :let [_ (prn '=args =args)]]
+    (return (annotated [::call =fn =args] [::&type/object "java.lang.Object" []]))))
 
 (defanalyser analyse-if
   [::&parser/if ?test ?then ?else]
   (exec [=test (analyse-form* ?test)
+         :let [_ (prn '=test =test)]
+         :let [_ (prn 'PRE '?then ?then)]
          =then (analyse-form* ?then)
-         =else (analyse-form* ?else)]
+         :let [_ (prn '=then =then)]
+         =else (analyse-form* ?else)
+         :let [_ (prn '=else =else)]]
     (return (annotated [::if =test =then =else] ::&type/nothing))))
 
 (defanalyser analyse-let
@@ -181,14 +213,14 @@
                    ?ident))]
       (exec [[=function =args =return] (within :types (&type/fresh-function (count args)))
              :let [_ (prn '[=function =args =return] [=function =args =return])]
-             :let [env (-> {}
-                           (assoc ?name =function)
-                           (into (map vector args =args)))
-                   _ (prn 'env env)]
+             ;; :let [env (-> {}
+             ;;               (assoc ?name =function)
+             ;;               (into (map vector args =args)))
+             ;;       _ (prn 'env env)]
              =value (reduce (fn [inner [label type]]
                               (with-local label type inner))
                             (analyse-form* ?value)
-                            (map vector args =args))
+                            (reverse (map vector args =args)))
              :let [_ (prn '=value =value)]
              =function (within :types (exec [_ (&type/solve =return (:type =value))]
                                         (&type/clean =function)))
@@ -199,6 +231,25 @@
         (return (annotated [::def [?name args] =value] ::&type/nothing))))
     ))
 
+(defanalyser analyse-lambda
+  [::&parser/lambda ?args ?body]
+  (exec [:let [_ (prn 'analyse-lambda ?args ?body)]
+         [=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)]])
+         :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))))
+         :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))))
+
 (defanalyser analyse-import
   [::&parser/import ?class]
   (exec [_ (import-class ?class (last (string/split ?class #"\.")))]
@@ -217,6 +268,7 @@
               analyse-string
               analyse-variant
               analyse-tuple
+              analyse-lambda
               analyse-ident
               analyse-ann-class
               analyse-static-access
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index e8f0207b3..b7079fecf 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -26,6 +26,7 @@
   `(defn ~name [~'*state*]
      (let [~'*class-name* (:class-name ~'*state*)
            ~'*writer* (:writer ~'*state*)
+           ~'*parent* (:parent ~'*state*)
            ~'*type* (:type (:form ~'*state*))]
        (match (:form (:form ~'*state*))
          ~match
@@ -61,7 +62,10 @@
     (->type-signature ?name)
 
     [::&type/variant ?tag ?value]
-    (->type-signature +variant-class+)))
+    (->type-signature +variant-class+)
+
+    [::&type/function ?args ?return]
+    (->java-sig [::&type/object "test2/Function" []])))
 
 ;; [Utils/Compilers]
 (defcompiler ^:private compile-literal
@@ -119,6 +123,20 @@
   [::&analyser/call ?fn ?args]
   (do (prn 'compile-call (:form ?fn) ?fn ?args)
     (match (:form ?fn)
+      [::&analyser/local _]
+      (do (compile-form (assoc *state* :form ?fn))
+        (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
+          (doseq [arg ?args]
+            (compile-form (assoc *state* :form arg))
+            (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
+      
+      [::&analyser/lambda _ ?body]
+      (do (compile-form (assoc *state* :form ?fn))
+        (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
+          (doseq [arg ?args]
+            (compile-form (assoc *state* :form arg))
+            (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
+      
       [::&analyser/global ?owner-class ?fn-name]
       (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
             signature "()V"
@@ -127,7 +145,7 @@
           (.visitTypeInsn Opcodes/NEW call-class)
           (.visitInsn Opcodes/DUP)
           (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" signature))
-        (doseq [arg (reverse ?args)]
+        (doseq [arg ?args]
           (compile-form (assoc *state* :form arg))
           (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))
         ))))
@@ -143,7 +161,8 @@
     (doseq [arg ?args]
       (compile-form (assoc *state* :form arg)))
     (doto *writer*
-      (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") ?method "(Ljava/lang/Object;)V"))))
+      (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") ?method "(Ljava/lang/Object;)V")
+      (.visitInsn Opcodes/ACONST_NULL))))
 
 (defcompiler ^:private compile-ann-class
   [::&analyser/ann-class ?class ?members]
@@ -170,6 +189,7 @@
   (let [start-label (new Label)
         end-label (new Label)
         ?idx (int ?idx)]
+    (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value)))
     (.visitLocalVariable *writer* ?label (->java-sig (:type ?value)) nil start-label end-label ?idx)
     (assert (compile-form (assoc *state* :form ?value)) "CAN't COMPILE LET-VALUE")
     (doto *writer*
@@ -249,7 +269,7 @@
                 =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
                           (.visitCode))]
             ;; (prn 'FN/?body ?body)
-            (assert (compile-form (assoc *state* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body)))
+            (assert (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body)))
             (doto =method
               (.visitInsn Opcodes/RETURN)
               (.visitMaxs 0 0)
@@ -258,7 +278,7 @@
                 _ (prn 'signature signature)
                 =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
                           (.visitCode))]
-            (compile-form (assoc *state* :writer =method :form ?body))
+            (compile-form (assoc *state* :parent *writer* :writer =method :form ?body))
             (doto =method
               (.visitInsn Opcodes/ARETURN)
               (.visitMaxs 0 0)
@@ -266,6 +286,78 @@
             (compile-method-function *writer* *class-name* ?name (count ?args)))))
       )))
 
+(defcompiler ^:private compile-lambda
+  [::&analyser/lambda ?args ?body]
+  (let [num-args (count ?args)
+        signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")
+        outer-class (->class *class-name*)
+        clo-field-sig (->type-signature "java.lang.Object")
+        apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
+        real-signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")]
+    (doseq [idx (range num-args)
+            :let [has-next? (not= idx (dec num-args))
+                  local-name (str "lambda_" idx)
+                  current-class (str outer-class "$" local-name)
+                  next-class (str outer-class "$" "lambda_" (inc idx))
+                  current-signature (str "(" (apply str (repeat idx "Ljava/lang/Object;")) ")" "V")
+                  next-signature (str "(" (apply str (repeat (inc idx) "Ljava/lang/Object;")) ")" "V")]]
+      (.visitInnerClass *parent* current-class outer-class local-name (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
+      (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+                     (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+                             current-class nil "java/lang/Object" (into-array ["test2/Function"])))
+            _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" current-signature nil nil)
+                (.visitCode)
+                (.visitVarInsn Opcodes/ALOAD 0)
+                (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+                (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+                      (.visitVarInsn Opcodes/ALOAD (inc clo_idx))
+                      (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
+                    (->> (let [field-name (str "_" clo_idx)]
+                           (doto (.visitField =class Opcodes/ACC_PUBLIC field-name clo-field-sig nil nil)
+                             (.visitEnd)))
+                         (dotimes [clo_idx idx])))
+                (.visitInsn Opcodes/RETURN)
+                (.visitMaxs 0 0)
+                (.visitEnd))
+            =method (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil)
+                      (.visitCode))
+            _ (do (when has-next?
+                    (doto =method
+                      (.visitTypeInsn Opcodes/NEW next-class)
+                      (.visitInsn Opcodes/DUP)))
+                (doto =method
+                  (-> (doto (.visitVarInsn Opcodes/ALOAD (int 0))
+                        (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
+                      (->> (dotimes [clo_idx idx])))
+                  (.visitVarInsn Opcodes/ALOAD (int 1)))
+                (if has-next?
+                  (.visitMethodInsn =method Opcodes/INVOKESPECIAL next-class "<init>" next-signature)
+                  (.visitMethodInsn =method Opcodes/INVOKESTATIC outer-class "lambda_impl" real-signature))
+                (doto =method
+                  (.visitInsn Opcodes/ARETURN)
+                  (.visitMaxs 0 0)
+                  (.visitEnd))
+                (.visitEnd =class))]
+        (println "OUTPUT LAMBDA:" (str current-class ".class"))
+        (write-file (str current-class ".class") (.toByteArray =class))))
+    (let [=method (doto (.visitMethod *parent* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "lambda_impl" real-signature nil nil)
+                    (.visitCode))]
+      (prn '(:form ?body) (:form ?body))
+      (compile-form (assoc *state* :parent *parent* :writer =method :form ?body))
+      (doto =method
+        (.visitInsn Opcodes/ARETURN)
+        (.visitMaxs 0 0)
+        (.visitEnd))
+      ;; (compile-form (assoc *state* :writer =method :form ?body))
+      ;; (compile-method-function *writer* *class-name* ?name (count ?args))
+      )
+    (let [init-class (str outer-class "$" "lambda_0")]
+      (doto *writer*
+        (.visitTypeInsn Opcodes/NEW init-class)
+        (.visitInsn Opcodes/DUP)
+        (.visitMethodInsn Opcodes/INVOKESPECIAL init-class "<init>" "()V")))
+    ))
+
 (defcompiler ^:private compile-defclass
   [::&analyser/defclass [?package ?name] ?members]
   (let [parent-dir (->package ?package)
@@ -351,6 +443,7 @@
                    compile-ann-class
                    compile-if
                    compile-let
+                   compile-lambda
                    compile-def
                    compile-defclass
                    compile-definterface
@@ -372,7 +465,8 @@
         ;;                  "output" nil "java/lang/Object" nil))
         state {:class-name class-name
                :writer =class
-               :form nil}]
+               :form nil
+               :parent nil}]
     ;; (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
     ;;   (.visitCode)
     ;;   (.visitVarInsn Opcodes/ALOAD 0)
diff --git a/src/lang/parser.clj b/src/lang/parser.clj
index 3149cf5d4..2f9a26c66 100644
--- a/src/lang/parser.clj
+++ b/src/lang/parser.clj
@@ -56,6 +56,11 @@
                        (partition 2 ?parts)))]
     (return [::record =kvs])))
 
+(defparser ^:private parse-lambda
+  [::&lexer/list ([[::&lexer/ident "lambda"] [::&lexer/tuple ?args] ?body] :seq)]
+  (exec [=body (apply-m parse-form (list ?body))]
+    (return [::lambda (mapv ident->string ?args) =body])))
+
 (defparser ^:private parse-def
   [::&lexer/list ([[::&lexer/ident "def"] ?name ?body] :seq)]
   (exec [=name (apply-m parse-form (list ?name))
@@ -192,6 +197,7 @@
               parse-ident
               parse-tuple
               parse-record
+              parse-lambda
               parse-def
               parse-defdata
               parse-if
diff --git a/src/lang/type.clj b/src/lang/type.clj
index 2f708867e..465f6e9fc 100644
--- a/src/lang/type.clj
+++ b/src/lang/type.clj
@@ -79,5 +79,8 @@
            =return (clean ?return)]
       (return [::function =args =return]))
 
+    ;; ::any
+    ;; (return [::object "java.lang.Object" []])
+    
     _
     (return type)))
diff --git a/test2.lang b/test2.lang
index e52e667d7..c8f2147ed 100644
--- a/test2.lang
+++ b/test2.lang
@@ -25,9 +25,16 @@
 (def sample (#Tag "value"))
 
 (def (constant x y)
-  y)
+  x)
 
 (def (main args)
   (if true
-    (_. (_.. System out) (println ["TRUE" "YOLO"]))
+    (_. (_.. System out) (println ((lambda [x y] x) "TRUE" "YOLO")))
     (_. (_.. System out) (println "FALSE"))))
+
+#( (let output ((lambda [x y] x) "TRUE" "YOLO")
+        (_. (_.. System out) (println output))) )#
+#( (let f (lambda [x y] x)
+        (_. (_.. System out) (println (f "TRUE" "YOLO")))) )#
+## ((lambda [x y] (_. (_.. System out) (println x))) "TRUE" "YOLO")
+## (_. (_.. System out) (println ((lambda [x y] x) "TRUE" "YOLO")))