Pattern-matching has been enriched with sub-structural matching.

4 files changed, 112 insertions, 53 deletions

diff --git a/another.lang b/another.lang
index 9ff9f8885..ff5bb6f0a 100644
--- a/another.lang
+++ b/another.lang
@@ -2,8 +2,3 @@
 ## (ann id #type (All [x] (-> [x] x)))
 (def (id x)
   x)
-
-#( (def (id x)
-     (let return "RETURN"
-          return))
-   )#
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 7c94c77d5..64bdbac9b 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -445,21 +445,36 @@
                                                              (with-anon-locals num-members
                                                                (fn [=locals]
                                                                  ;; (prn '?branch/=locals (map :form =locals))
-                                                                 (exec [=members (reduce-m (fn [[locals-map =members] [?local ?member]]
-                                                                                             (match ?member
-                                                                                               [::&parser/ident ?name]
-                                                                                               (return [(assoc locals-map ?name ?local) (conj =members (:form ?local))])))
-                                                                                           [{} []]
-                                                                                           (map vector =locals ?members))
+                                                                 (exec [[inner-num locals+ members+] (reduce-m (fn member-fold [[?inner-num locals-map =members] [?local ?member]]
+                                                                                                                 (match ?member
+                                                                                                                   [::&parser/ident ?name]
+                                                                                                                   (return [?inner-num
+                                                                                                                            (assoc locals-map ?name ?local)
+                                                                                                                            (conj =members (:form ?local))])
+
+                                                                                                                   [::&parser/variant ?subtag ?submembers]
+                                                                                                                   (let [num-submembers (count ?submembers)]
+                                                                                                                     (with-anon-locals num-submembers
+                                                                                                                       (fn [=sublocals]
+                                                                                                                         (exec [[subinner-num sublocals+ submembers+] (reduce-m member-fold [0 {} []] (map vector =sublocals ?submembers))
+                                                                                                                                ;; :let [_ (prn 'subinner-num subinner-num 'sublocals+ sublocals+ 'submembers+ submembers+)]
+                                                                                                                                ]
+                                                                                                                           (return [(+ ?inner-num num-submembers subinner-num)
+                                                                                                                                    (merge locals-map sublocals+)
+                                                                                                                                    (conj =members [::subcase ?subtag submembers+])])))))
+                                                                                                                   ))
+                                                                                                               [0 {} []]
+                                                                                                               (map vector =locals ?members))
+                                                                        ;; :let [_ (prn 'inner-num inner-num 'locals+ locals+ 'members+ members+)]
                                                                         ;; :let [_ (prn (first =members) ?body)]
-                                                                        =body (with-locals (first =members)
+                                                                        =body (with-locals locals+
                                                                                 (analyse-form* ?body))
                                                                         ;; :let [_ (prn '?body ?body =body)]
                                                                         ]
-                                                                   (return [num-members [::branch-adt ?tag (second =members) =body]])))))))
+                                                                   (return [(+ num-members inner-num) [::branch-adt ?tag members+ =body]])))))))
                                                        ?branches)]
                                  (return [(first =locals) =branches]))))
-         :let [total-registers (reduce + 1 (map first =branches))
+         :let [total-registers (+ 1 (reduce max 0 (map first =branches)))
                ;; _ (prn '=branches total-registers (map second =branches))
                ;; _ (assert false)
                ]
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index e425fa0f1..f26d111a4 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -288,46 +288,87 @@
   (defcompiler ^:private compile-case
     ;; [::&analyser/case ?variant ?branches]
     [::&analyser/case ?base ?variant ?registers ?branches]
-    (do ;; (prn [:case ?base ?variant ?registers ?branches])
-      (match (:form ?base)
-        [::&analyser/local _ ?base-idx]
-        (let [start-label (new Label)
-              end-label (new Label)]
-          (dotimes [idx ?registers]
-            (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
-          (.visitLabel *writer* start-label)
-          (compile-form (assoc *state* :form ?variant))
-          (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
-          (let [variant-class* (->class +variant-class+)]
+    (let [variant-class* (->class +variant-class+)]
+      ;; (prn [:case ?base ?variant ?registers ?branches])
+        (match (:form ?base)
+          [::&analyser/local _ ?base-idx]
+          (let [start-label (new Label)
+                end-label (new Label)
+                default-label (new Label)]
+            (dotimes [idx ?registers]
+              (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
+            (.visitLabel *writer* start-label)
+            (compile-form (assoc *state* :form ?variant))
+            (.visitTypeInsn *writer* Opcodes/CHECKCAST variant-class*)
+            (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
             (doseq [?branch ?branches
                     :let [else-label (new Label)]]
               (match ?branch
                 [::&analyser/branch-adt ?tag ?members ?body]
-                (let [tuple-class (str "test2/Tuple" (count ?members))]
-                  (when (not (empty? ?members))
-                    (do (doto *writer*
-                          (.visitVarInsn Opcodes/ALOAD ?base-idx)
-                          (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
-                          (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
-                      (doseq [[?tfield member] (map vector (range (count ?members)) ?members)]
-                        (match member
-                          [:lang.analyser/local 0 ?idx]
+                (doto *writer*
+                  (.visitVarInsn Opcodes/ALOAD ?base-idx)
+                  (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
+                  (.visitLdcInsn ?tag)
+                  (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
+                  (.visitJumpInsn Opcodes/IFEQ else-label)
+                  (do (when (not (empty? ?members))
+                        (let [tuple-class (str "test2/Tuple" (count ?members))
+                              mk-sub-fold (fn mk-sub-fold [cleanup-level default-label tuple-class]
+                                            (fn sub-fold [?tfield member]
+                                              (let [next-label (new Label)]
+                                                (match member
+                                                  [::&analyser/local 0 ?idx]
+                                                  (doto *writer*
+                                                    (.visitInsn Opcodes/DUP)
+                                                    (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
+                                                    (.visitVarInsn Opcodes/ASTORE ?idx))
+
+                                                  [::&analyser/subcase ?subtag ?submembers]
+                                                  (let [tuple-class* (str "test2/Tuple" (count ?submembers))
+                                                        cleanup-label (new Label)]
+                                                    (doto *writer*
+                                                      (.visitInsn Opcodes/DUP)
+                                                      (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
+                                                      (.visitTypeInsn Opcodes/CHECKCAST variant-class*)
+                                                      (.visitInsn Opcodes/DUP)
+                                                      (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
+                                                      (.visitLdcInsn ?subtag)
+                                                      (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
+                                                      (.visitJumpInsn Opcodes/IFEQ cleanup-label)
+                                                      (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
+                                                      (.visitTypeInsn Opcodes/CHECKCAST tuple-class*)
+                                                      (do (dorun (map (mk-sub-fold (inc cleanup-level) default-label tuple-class*)
+                                                                      (range (count ?submembers))
+                                                                      ?submembers)))
+                                                      (.visitInsn Opcodes/POP)
+                                                      (.visitJumpInsn Opcodes/GOTO next-label)
+                                                      (.visitLabel cleanup-label)
+                                                      (-> (doto (.visitInsn Opcodes/POP))
+                                                          (->> (dotimes [_ (inc cleanup-level)])))
+                                                      (.visitJumpInsn Opcodes/GOTO default-label)
+                                                      (.visitLabel next-label)
+                                                      ))))))]
                           (doto *writer*
-                            (.visitInsn Opcodes/DUP)
-                            (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
-                            (.visitVarInsn Opcodes/ASTORE ?idx))))
-                      (.visitInsn *writer* Opcodes/POP)))
-                  (doto *writer*
-                    (.visitVarInsn Opcodes/ALOAD ?base-idx)
-                    (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
-                    (.visitLdcInsn ?tag)
-                    (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
-                    (.visitJumpInsn Opcodes/IFEQ else-label)
-                    (do (compile-form (assoc *state* :form ?body)))
-                    (.visitJumpInsn Opcodes/GOTO end-label)
-                    (.visitLabel else-label))))))
-          (.visitInsn *writer* Opcodes/ACONST_NULL)
-          (.visitLabel *writer* end-label)))
+                            (.visitVarInsn Opcodes/ALOAD ?base-idx)
+                            (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
+                            (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
+                          (dorun (map (mk-sub-fold 1 default-label tuple-class)
+                                      (range (count ?members))
+                                      ?members))
+                          (.visitInsn *writer* Opcodes/POP)))
+                    (compile-form (assoc *state* :form ?body)))
+                  (.visitJumpInsn Opcodes/GOTO end-label)
+                  (.visitLabel else-label))))
+            ;; Default branch
+            (let [ex-class (->class "java.lang.IllegalStateException")]
+              (doto *writer*
+                (.visitLabel default-label)
+                (.visitInsn Opcodes/ACONST_NULL)
+                (.visitTypeInsn Opcodes/NEW ex-class)
+                (.visitInsn Opcodes/DUP)
+                (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+                (.visitInsn Opcodes/ATHROW)))
+            (.visitLabel *writer* end-label)))
       )))
 
 (defcompiler ^:private compile-let
diff --git a/test2.lang b/test2.lang
index cbce36ce8..55d7a14af 100644
--- a/test2.lang
+++ b/test2.lang
@@ -1,5 +1,5 @@
 (import java.lang.System)
-## (require "./another" as another)
+(require "./another" as another)
 
 (definterface Function
   (: apply (-> [java.lang.Object] java.lang.Object)))
@@ -18,11 +18,19 @@
        (#Cons x xs*)
        (#Cons x (++ xs* ys)))) )#
 
+#( (def (main args)
+     (if true
+       (case (#Pair "Pattern" "Matching")
+         (#Pair first second)
+         (do (:: (:: System out) (println first))
+           (:: (:: System out) (println second))))
+       (:: (:: System out) (println "FALSE")))) )#
+
 (def (main args)
   (if true
-    (let variant (#Pair "Pattern" "Matching")
-         (case variant
-           (#Pair first second)
+    (let xs+ys (#Cons "Pattern" (#Cons "Matching" #Nil))
+         (case xs+ys
+           (#Cons first (#Cons second #Nil))
            (do (:: (:: System out) (println first))
              (:: (:: System out) (println second)))))
     (:: (:: System out) (println "FALSE"))))