Added some pseudo pattern-matching (only extracting simple data, without exploring inner structure or doing any testing).

4 files changed, 140 insertions, 73 deletions

diff --git a/src/lang.clj b/src/lang.clj
index 0aaba1b81..f12ffc8d5 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -11,7 +11,6 @@
     (.write stream data)))
 
 (comment
-  ;; TODO: Add pattern-matching.
   ;; 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)
@@ -28,7 +27,7 @@
   ;; TODO: Adding metadata to global vars.
   ;; TODO: Add records.
   ;; TODO: throw, try, catch, finally
-  ;; TODO: 
+  ;; TODO: Finish implementing pattern matching.
   ;; TODO: 
   
   (let [source-code (slurp "test2.lang")
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 0cab85f66..bc48a0c81 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -55,7 +55,7 @@
                                                                                                   _
                                                                                                   true)]
                                                                                       [k v]))]
-                                                                   (prn 'ms ms 'ms* ms*)
+                                                                   ;; (prn 'ms ms 'ms* ms*)
                                                                    ms*))))))]
       (match =return
         [::&util/ok [?state ?value]]
@@ -80,7 +80,7 @@
   (fn [state]
     (if-let [[_ ?alias ?binding] (re-find #"^(.*)/(.*)$" ident)]
       (let [?module (get-in state [:deps ?alias])]
-        (prn 'resolve ?module ?alias ?binding)
+        ;; (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]]
@@ -96,10 +96,12 @@
          (fail* (str "Unmatched token: " token#))))))
 
 (defn analyse-form* [form]
-  (prn 'analyse-form* form)
+  ;; (prn 'analyse-form* form)
   (fn [state]
     (let [old-forms (:forms state)
-          =return (analyse-form (assoc state :forms (list form)))]
+          =return (analyse-form (assoc state :forms (list form)))
+          ;; _ (prn 'analyse-form*/=return =return)
+          ]
       (match =return
         [::&util/ok [?state ?value]]
         [::&util/ok [(assoc ?state :forms old-forms) ?value]]
@@ -121,7 +123,10 @@
 
 (defanalyser analyse-variant
   [::&parser/tagged ?tag ?value]
-  (exec [=value (analyse-form* ?value)]
+  (exec [;; :let [_ (prn 'analyse-variant [?tag ?value])]
+         =value (analyse-form* ?value)
+         ;; :let [_ (prn '=value =value)]
+         ]
     (return (annotated [::variant ?tag =value] [::&type/variant ?tag (:type =value)]))))
 
 (defanalyser analyse-tuple
@@ -132,7 +137,8 @@
 (defanalyser analyse-ident
   [::&parser/ident ?ident]
   (exec [_env (fn [state] [::&util/ok [state (:env state)]])
-         :let [_ (prn 'analyse-ident ?ident _env)]]
+         ;; :let [_ (prn 'analyse-ident ?ident _env)]
+         ]
     (resolve ?ident)))
 
 (defanalyser analyse-ann-class
@@ -142,7 +148,8 @@
 (defanalyser analyse-static-access
   [::&parser/static-access ?target ?member]
   (exec [=target (resolve ?target)
-         :let [_ (prn '=target ?target (:form =target))]]
+         ;; :let [_ (prn '=target ?target (:form =target))]
+         ]
     (match (:form =target)
       [::class ?class]
       (return (annotated [::static-access ?class ?member] ::&type/nothing)))))
@@ -157,22 +164,24 @@
 
 (defanalyser analyse-fn-call
   [::&parser/fn-call ?fn ?args]
-  (exec [:let [_ (prn 'PRE '?fn ?fn)]
+  (exec [;; :let [_ (prn 'PRE '?fn ?fn)]
          =fn (analyse-form* ?fn)
-         :let [_ (prn '=fn =fn)]
+         ;; :let [_ (prn '=fn =fn)]
          =args (map-m analyse-form* ?args)
-         :let [_ (prn '=args =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)]
+         ;; :let [_ (prn '=test =test)]
+         ;; :let [_ (prn 'PRE '?then ?then)]
          =then (analyse-form* ?then)
-         :let [_ (prn '=then =then)]
+         ;; :let [_ (prn '=then =then)]
          =else (analyse-form* ?else)
-         :let [_ (prn '=else =else)]]
+         ;; :let [_ (prn '=else =else)]
+         ]
     (return (annotated [::if =test =then =else] ::&type/nothing))))
 
 (defanalyser analyse-do
@@ -180,6 +189,27 @@
   (exec [=exprs (map-m analyse-form* ?exprs)]
     (return (annotated [::do =exprs] (-> =exprs last :type)))))
 
+(defanalyser analyse-case
+  [::&parser/case ?variant ?branches]
+  (exec [;; :let [_ (prn '?variant ?variant)]
+         =variant (analyse-form* ?variant)
+         ;; :let [_ (prn '=variant =variant)]
+         =branches (map-m (fn [branch]
+                            ;; (prn 'branch branch)
+                            (match branch
+                              [::&parser/case-branch [::&parser/tagged ?tag [::&parser/ident ?label]] ?body]
+                              (exec [;; :let [_ (prn ?tag ?label '?body ?body)]
+                                     idx next-local-idx
+                                     =body (with-local ?label [::&type/object "java.lang.Object" []]
+                                             (analyse-form* ?body))
+                                     ;; :let [_ (prn ?tag ?label '=body =body)]
+                                     ]
+                                (return [?tag ?label idx =body]))))
+                          ?branches)
+         ;; :let [_ (prn '=branches =branches)]
+         ]
+    (return (annotated [::case =variant =branches] ::&type/nothing))))
+
 (defanalyser analyse-let
   [::&parser/let ?label ?value ?body]
   (exec [=value (analyse-form* ?value)
@@ -222,7 +252,7 @@
                    [::&parser/ident ?ident]
                    ?ident))]
       (exec [[=function =args =return] (within :types (&type/fresh-function (count args)))
-             :let [_ (prn '[=function =args =return] [=function =args =return])]
+             ;; :let [_ (prn '[=function =args =return] [=function =args =return])]
              ;; :let [env (-> {}
              ;;               (assoc ?name =function)
              ;;               (into (map vector args =args)))
@@ -231,10 +261,10 @@
                               (with-local label type inner))
                             (analyse-form* ?value)
                             (reverse (map vector args =args)))
-             :let [_ (prn '=value =value)]
+             ;; :let [_ (prn '=value =value)]
              =function (within :types (exec [_ (&type/solve =return (:type =value))]
                                         (&type/clean =function)))
-             :let [_ (prn '=function =function)]
+             ;; :let [_ (prn '=function =function)]
              _ (define ?name {:mode ::function
                               :access ::public
                               :type =function})]
@@ -243,21 +273,22 @@
 
 (defanalyser analyse-lambda
   [::&parser/lambda ?args ?body]
-  (exec [:let [_ (prn 'analyse-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)]
+         ;; :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)]
+         ;; :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)]
+         ;; :let [_ (prn '=body =body)]
          =function (within :types (exec [_ (&type/solve =return (:type =body))]
                                     (&type/clean =function)))
-         :let [_ (prn '=function =function)]]
+         ;; :let [_ (prn '=function =function)]
+         ]
     (return (annotated [::lambda ?args =body] =function))))
 
 (defanalyser analyse-import
@@ -267,9 +298,10 @@
 
 (defanalyser analyse-require
   [::&parser/require ?file ?alias]
-  (let [_ (prn `[require ~?file ~?alias])
+  (let [;; _ (prn `[require ~?file ~?alias])
         module-name (re-find #"[^/]+$" ?file)
-        _ (prn 'module-name module-name)]
+        ;; _ (prn 'module-name module-name)
+        ]
     (exec [_ (require-module module-name ?alias)]
       (return (annotated [::require ?file ?alias] ::&type/nothing)))))
 
@@ -289,6 +321,7 @@
               analyse-fn-call
               analyse-if
               analyse-do
+              analyse-case
               analyse-let
               analyse-defclass
               analyse-definterface
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index b29bc38d1..48cbe3999 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -142,7 +142,7 @@
 
 (defcompiler ^:private compile-call
   [::&analyser/call ?fn ?args]
-  (do (prn 'compile-call (:form ?fn) ?fn ?args)
+  (do ;; (prn 'compile-call (:form ?fn) ?fn ?args)
     (match (:form ?fn)
       [::&analyser/local _]
       (do (compile-form (assoc *state* :form ?fn))
@@ -198,7 +198,7 @@
     (doto *writer*
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Boolean") "booleanValue" "()Z")
       (.visitJumpInsn Opcodes/IFEQ else-label))
-    (prn 'compile-if/?then (:form ?then))
+    ;; (prn 'compile-if/?then (:form ?then))
     (assert (compile-form (assoc *state* :form ?then)) "CAN't COMPILE THEN")
     (doto *writer*
       (.visitJumpInsn Opcodes/GOTO end-label)
@@ -213,12 +213,45 @@
         (.visitInsn *writer* Opcodes/POP))
     (compile-form (assoc *state* :form (last ?exprs)))))
 
+(let [oclass (->class "java.lang.Object")
+      equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
+  (defcompiler ^:private compile-case
+    [::&analyser/case ?variant ?branches]
+    (do (compile-form (assoc *state* :form ?variant))
+      (let [end-label (new Label)]
+        (doseq [[?tag ?label ?idx ?body] ?branches]
+          ;; (prn '[?tag ?label ?idx ?body] [?tag ?label ?idx ?body])
+          (let [else-label (new Label)]
+            (doto *writer*
+              (.visitInsn Opcodes/DUP)
+              (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" "Ljava/lang/String;")
+              (.visitLdcInsn ?tag)
+              (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
+              (.visitJumpInsn Opcodes/IFEQ else-label))
+            (let [start-label (new Label)
+                  end-label (new Label)]
+              (doto *writer*
+                (.visitInsn Opcodes/DUP)
+                (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "value" (->type-signature "java.lang.Object")))
+              (.visitLocalVariable *writer* ?label (->type-signature "java.lang.Object") nil start-label end-label ?idx)
+              (doto *writer*
+                (.visitVarInsn Opcodes/ASTORE ?idx)
+                (.visitLabel start-label)
+                (.visitInsn Opcodes/POP))
+              (compile-form (assoc *state* :form ?body))
+              (.visitLabel *writer* end-label))
+            (doto *writer*
+              (.visitJumpInsn Opcodes/GOTO end-label)
+              (.visitLabel else-label))))
+        (.visitLabel *writer* end-label))
+      )))
+
 (defcompiler ^:private compile-let
   [::&analyser/let ?idx ?label ?value ?body]
   (let [start-label (new Label)
         end-label (new Label)
         ?idx (int ?idx)]
-    (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value)))
+    ;; (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*
@@ -282,38 +315,38 @@
 
 (defcompiler ^:private compile-def
   [::&analyser/def ?form ?body]
-  (do (prn 'compile-def ?form)
-    (match ?form
-      (?name :guard string?)
-      (let [=type (:type ?body)
-            ;; _ (prn '?body ?body)
-            ]
-        (doto (.visitField *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name (->java-sig =type) nil nil)
-          (.visitEnd)))
-
-      [?name ?args]
-      (do (prn 'compile-def `(~'def (~(symbol ?name) ~@(map symbol ?args))))
-        (if (= "main" ?name)
-          (let [signature "([Ljava/lang/String;)V"
-                =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
-                          (.visitCode))]
-            ;; (prn 'FN/?body ?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)
-              (.visitEnd)))
-          (let [signature (str "(" (apply str (repeat (count ?args) "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")
-                _ (prn 'signature signature)
-                =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
-                          (.visitCode))]
-            (compile-form (assoc *state* :parent *writer* :writer =method :form ?body))
-            (doto =method
-              (.visitInsn Opcodes/ARETURN)
-              (.visitMaxs 0 0)
-              (.visitEnd))
-            (compile-method-function *writer* *class-name* ?name (count ?args)))))
-      )))
+  (do ;; (prn 'compile-def ?form)
+      (match ?form
+        (?name :guard string?)
+        (let [=type (:type ?body)
+              ;; _ (prn '?body ?body)
+              ]
+          (doto (.visitField *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name (->java-sig =type) nil nil)
+            (.visitEnd)))
+
+        [?name ?args]
+        (do ;; (prn 'compile-def `(~'def (~(symbol ?name) ~@(map symbol ?args))))
+            (if (= "main" ?name)
+              (let [signature "([Ljava/lang/String;)V"
+                    =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
+                              (.visitCode))]
+                ;; (prn 'FN/?body ?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)
+                  (.visitEnd)))
+              (let [signature (str "(" (apply str (repeat (count ?args) "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")
+                    ;; _ (prn 'signature signature)
+                    =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
+                              (.visitCode))]
+                (compile-form (assoc *state* :parent *writer* :writer =method :form ?body))
+                (doto =method
+                  (.visitInsn Opcodes/ARETURN)
+                  (.visitMaxs 0 0)
+                  (.visitEnd))
+                (compile-method-function *writer* *class-name* ?name (count ?args)))))
+        )))
 
 (defcompiler ^:private compile-lambda
   [::&analyser/lambda ?args ?body]
@@ -371,7 +404,7 @@
         (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))
+      ;; (prn '(:form ?body) (:form ?body))
       (compile-form (assoc *state* :parent *parent* :writer =method :form ?body))
       (doto =method
         (.visitInsn Opcodes/ARETURN)
@@ -448,15 +481,15 @@
 (defcompiler compile-require
   [::&analyser/require ?file ?alias]
   (let [module-name (re-find #"[^/]+$" ?file)
-        _ (prn 'module-name module-name)
+        ;; _ (prn 'module-name module-name)
         source-code (slurp (str module-name ".lang"))
-        _ (prn 'source-code source-code)
+        ;; _ (prn 'source-code source-code)
         tokens (&lexer/lex source-code)
-        _ (prn 'tokens tokens)
+        ;; _ (prn 'tokens tokens)
         syntax (&parser/parse tokens)
-        _ (prn 'syntax syntax)
+        ;; _ (prn 'syntax syntax)
         ann-syntax (&analyser/analyse module-name syntax)
-        _ (prn 'ann-syntax ann-syntax)
+        ;; _ (prn 'ann-syntax ann-syntax)
         class-data (compile module-name ann-syntax)]
     (write-file (str module-name ".class") class-data)
     nil))
@@ -472,6 +505,7 @@
                    compile-ann-class
                    compile-if
                    compile-do
+                   compile-case
                    compile-let
                    compile-lambda
                    compile-def
diff --git a/src/lang/lexer.clj b/src/lang/lexer.clj
index 93bdf51aa..870209503 100644
--- a/src/lang/lexer.clj
+++ b/src/lang/lexer.clj
@@ -74,12 +74,13 @@
 
 (def ^:private lex-string
   (exec [_ (lex-str "\"")
-         state &util/get-state
-         :let [_ (prn 'PRE state)]
+         ;; state &util/get-state
+         ;; :let [_ (prn 'PRE state)]
          token lex-string-body
          _ (lex-str "\"")
-         state &util/get-state
-         :let [_ (prn 'POST state)]]
+         ;; state &util/get-state
+         ;; :let [_ (prn 'POST state)]
+         ]
     (return [::string token])))
 
 (def ^:private lex-single-line-comment
@@ -106,7 +107,7 @@
          ;; :let [_ (prn 'COMMENT comment)]
          _ (lex-str ")#")
          ;; :let [_ (prn 'CLOSE)]
-         :let [_ (prn 'multi-comment comment)]
+         ;; :let [_ (prn 'multi-comment comment)]
          ]
     (return [::comment comment])))