diff options
author | Eduardo Julian | 2015-01-02 03:29:32 -0400 |
---|---|---|
committer | Eduardo Julian | 2015-01-02 03:29:32 -0400 |
commit | 7ae54659d09aef5ced3544c650c80d7580a0dbb7 (patch) | |
tree | 562df421d70479622a01fb1915884b5f60a3a0aa | |
parent | f28db7decf3330379f3f4ab190a9bc01deb50b91 (diff) |
Fixed a bug in pattern-matching when expanding sequential tests.
-rw-r--r-- | src/lang/analyser.clj | 5 | ||||
-rw-r--r-- | src/lang/compiler.clj | 101 | ||||
-rw-r--r-- | test2.lang | 69 |
3 files changed, 124 insertions, 51 deletions
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index f45f44138..21117a7b7 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -535,6 +535,11 @@ ;; :let [_ (prn 'analyse-case '$base $base)] [registers mappings tree] (exec [=branches (map-m (fn [?branch] (match ?branch + [::&parser/case-branch [::&parser/ident ?name] ?body] + (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])} + (analyse-form* ?body))] + (return [::&parser/case-branch [::&parser/ident ?name] =body])) + [::&parser/case-branch [::&parser/variant ?tag ?members] ?body] (exec [[_ locals+] (reduce-m (fn member-fold [[$local locals-map] ?member] (match ?member diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj index e04178fed..2ead6daec 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -290,7 +290,7 @@ +tuple-field-sig+ (->type-signature "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] (defn compile-decision-tree [writer mappings cleanup-level next-label default-label decision-tree] - ;; (prn 'compile-decision-tree cleanup-level decision-tree) + (prn 'compile-decision-tree cleanup-level decision-tree) (match decision-tree [::test-text ?text $body] (let [$else (new Label)] @@ -307,9 +307,11 @@ (->> (dotimes [_ (inc cleanup-level)]))) (.visitJumpInsn Opcodes/GOTO default-label))) - [::store [::&analyser/local 0 ?idx] _] - ;; object - (.visitVarInsn writer Opcodes/ASTORE ?idx) ;; + [::store [::&analyser/local 0 ?idx] $body] + (doto writer + (.visitVarInsn Opcodes/ASTORE ?idx) + (-> (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (->> (when (nil? next-label))))) [::test-adt ?branches ?cases] (doto writer @@ -323,7 +325,8 @@ (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag (.visitInsn Opcodes/POP) ;; variant (do (let [arity (-> ?subcases first (nth 2) count) - tuple-class (str "test2/Tuple" arity)] + tuple-class (str "test2/Tuple" arity) + _ (prn ?tag arity tuple-class)] (when (> arity 0) (doto writer (.visitInsn Opcodes/DUP) ;; variant, variant @@ -352,14 +355,48 @@ ;; variant, tag -> (.visitLabel tag-else-label)) (->> (doseq [[?tag ?subcases] ?cases + :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))] :let [tag-else-label (new Label)]]))) (-> (doto (.visitInsn Opcodes/POP)) (->> (dotimes [_ (+ cleanup-level 2)]))) (.visitJumpInsn Opcodes/GOTO default-label))) )) +;; ([:lang.compiler/subcase 0 ([:lang.compiler/test-adt #{0} {"Symbol" ()}] +;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])] +;; [:lang.compiler/subcase 0 ([:lang.compiler/test-adt #{0} {"Symbol" ()}] +;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])] +;; [:lang.compiler/subcase 0 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] +;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])] +;; [:lang.compiler/subcase 0 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] +;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])] +;; [:lang.compiler/subcase 1 ([:lang.compiler/test-adt #{1} {"Symbol" ([:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 1])])}] +;; [:lang.compiler/test-adt #{1} {"Nil" ()}])] +;; [:lang.compiler/subcase 1 ([:lang.compiler/test-adt #{1} {"Symbol" ([:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 1])])}] +;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])] +;; [:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] +;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])] +;; [:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] +;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])]) + +;; ({:type :lang.analyser/adt*, +;; :patterns {"Cons" {:parts ({:type :lang.analyser/adt*, +;; :patterns {"Symbol" {:parts ({:type :lang.analyser/defaults, +;; :stores {[:lang.analyser/local 0 1] #{1}}, +;; :branches #{1}}), +;; :branches #{1}}}, +;; :default [:lang.analyser/default [:lang.analyser/local 0 1] 0], +;; :branches #{0 1}} +;; {:type :lang.analyser/adt*, +;; :patterns {"Nil" {:parts (), :branches #{0}}}, +;; :default [:lang.analyser/default [:lang.analyser/local 0 2] 1], +;; :branches #{0 1}}), +;; :branches #{0 1}}}, +;; :default nil, +;; :branches #{0 1}}) + (defn sequence-parts [branches parts] - ;; (.print System/out (prn-str 'sequence-parts branches parts)) + (.print System/out (prn-str 'sequence-parts branches parts)) (if (empty? parts) '(()) (let [[head & tail] parts @@ -382,12 +419,29 @@ [[::store ?local ?body] #{?body}])) ::&analyser/adt* - (do (assert (nil? (:default head))) - (list (list [::test-adt branches (into {} (for [[?tag ?struct] (:patterns head) - :let [?supports (:branches ?struct)]] - [?tag (for [?body (set/intersection branches ?supports) - subseq (sequence-parts #{?body} (:parts ?struct))] - [::subcase ?body subseq])]))]))) + (do ;; (prn '(:default head) (:default head)) + ;; (assert (nil? (:default head))) + (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) + :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))] + :let [?parts (:parts ?struct) + num-parts (count ?parts) + ?supports (:branches ?struct) + subcases (for [?body (set/intersection branches ?supports) + subseq (sequence-parts #{?body} ?parts) + :let [_ (when (= "Symbol" ?tag) + (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))] + :when (= num-parts (count subseq))] + [::subcase ?body subseq])] + :when (not (empty? subcases))] + [?tag subcases]))] + (if (empty? patterns) + '() + (list [[::test-adt branches patterns] + branches]))) + (if-let [[_ ?local ?body] (:default head)] + (for [?body (set/intersection branches #{?body})] + [[::store ?local ?body] #{?body}]) + '()))) )] (for [[step branches*] expanded tail* (sequence-parts branches* tail) @@ -395,6 +449,8 @@ ] (cons step tail*))))) +(def !case-vars (atom -1)) + (let [oclass (->class "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z") ex-class (->class "java.lang.IllegalStateException")] @@ -412,21 +468,22 @@ [label ?body]]) mappings* (into {} (map first entries))] (dotimes [idx ?max-registers] - (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx)))) + (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx)))) (compile-form (assoc *state* :form ?variant)) (.visitLabel *writer* start-label) (let [default-label (new Label) default-code (:default ?decision-tree)] - (compile-decision-tree *writer* mappings* 0 nil default-label - (-> (sequence-parts (:branches ?decision-tree) (list ?decision-tree)) - first first)) + ;; (prn 'sequence-parts + ;; (sequence-parts (:branches ?decision-tree) (list ?decision-tree))) + (doseq [decision-tree (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] + (compile-decision-tree *writer* mappings* 0 nil default-label decision-tree)) (.visitLabel *writer* default-label) - (if default-code - (do (prn 'default-code default-code) - (assert false) - ;; (.visitInsn Opcodes/POP) ;; ... - (compile-form (assoc *state* :form default-code)) - (.visitJumpInsn *writer* Opcodes/GOTO end-label)) + (when (not default-code) + ;; (do (prn 'default-code default-code) + ;; (assert false) + ;; ;; (.visitInsn Opcodes/POP) ;; ... + ;; (compile-form (assoc *state* :form default-code)) + ;; (.visitJumpInsn *writer* Opcodes/GOTO end-label)) (doto *writer* ;; (.visitInsn Opcodes/POP) (.visitTypeInsn Opcodes/NEW ex-class) diff --git a/test2.lang b/test2.lang index c697ae3c8..b3756a6e8 100644 --- a/test2.lang +++ b/test2.lang @@ -18,37 +18,36 @@ (#Cons x xs*) (#Cons x (++ xs* ys)))) -#( (def (template elems) - (case elems - #Nil - elems - - (#Cons head tail) - (case head - (#Cons (#Symbol "~") (#Cons unquoted #Nil)) - (#Cons unquoted (template tail)) +(def (template elems) + (case elems + #Nil + elems - (#Cons (#Symbol "~@") (#Cons spliced #Nil)) - (#Cons (#Symbol "++") (#Cons spliced (template tail))) + (#Cons head tail) + (case head + (#Cons (#Symbol "~") (#Cons unquoted #Nil)) + (#Cons unquoted (template tail)) - _ - (#Cons head (template tail))) - )) )# + (#Cons (#Symbol "~@") (#Cons spliced #Nil)) + (#Cons (#Symbol "++") (#Cons spliced (template tail))) -#( )# + _ + (#Cons head (template tail)) + ) + )) (def (main args) - (if true - (case (++ (#Cons "Pattern" #Nil) (#Cons "Matching" #Nil)) - (#Cons "Pattern" (#Cons second #Nil)) - (do (:: (:: System out) (println "Branch #1")) - (:: (:: System out) (println second))) - - (#Cons first (#Cons second #Nil)) - (do (:: (:: System out) (println "Branch #2")) - (:: (:: System out) (println first)) - (:: (:: System out) (println second)))) - (:: (:: System out) (println "FALSE")))) + (case (template (#Cons (#Cons (#Symbol "~@") (#Cons (#Symbol "Pattern") #Nil)) #Nil) + ## (#Cons (#Cons (#Symbol "~") (#Cons (#Symbol "Pattern") #Nil)) #Nil) + ) + (#Cons word #Nil) + (do (:: (:: System out) (println "Branch #1")) + (:: (:: System out) (println word))) + + (#Cons (#Symbol op) spliced) + (do (:: (:: System out) (println "Branch #2")) + (:: (:: System out) (println op))) + )) #( (defmacro (' form) (case form @@ -73,8 +72,20 @@ (def (main args) (if true (let f (lambda [x] (lambda [y] (x y))) - (let g (lambda [x] const) - (::+ System out (println (f g "WE'VE GOT CLOSURES!"))) - ## (:: (:: System out) (println (f g "WE'VE GOT CLOSURES!"))))) + (let g (lambda [x] x) + (::+ System out (println (f g "WE'VE GOT CLOSURES!"))))) + (:: (:: System out) (println "FALSE")))) + + (def (main args) + (if true + (case (++ (#Cons "Pattern" #Nil) (#Cons "Matching" #Nil)) + (#Cons "Pattern" (#Cons second #Nil)) + (do (:: (:: System out) (println "Branch #1")) + (:: (:: System out) (println second))) + + (#Cons first (#Cons second #Nil)) + (do (:: (:: System out) (println "Branch #2")) + (:: (:: System out) (println first)) + (:: (:: System out) (println second)))) (:: (:: System out) (println "FALSE")))) )# |