From 5a56806146d0bbf8309752f11fe601cf04624047 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 16 Jan 2015 14:25:32 -0400 Subject: [Bugs] - Char pattern-matching is now handled better and defaults now work for it. - Text pattern-matching is now handled better and defaults now work for it. --- src/lux/analyser.clj | 26 +++++++++++++++++ src/lux/compiler.clj | 82 ++++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 86 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index b192a2e31..07d3fb3b7 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -609,6 +609,17 @@ (let [fold-branch (fn [struct entry] (let [struct* (clojure.core.match/match (nth entry 0) + [::pm-char ?token] + (clojure.core.match/match (:type struct) + ::char-tests (update-in struct [:patterns ?token] (fn [bodies] + (if bodies + (conj bodies (nth entry 1)) + #{(nth entry 1)}))) + nil (-> struct + (assoc :type ::char-tests) + (assoc-in [:patterns ?token] #{(nth entry 1)})) + _ (assert false "Can't do match.")) + [::pm-text ?text] (clojure.core.match/match (:type struct) ::text-tests (update-in struct [:patterns ?text] (fn [bodies] @@ -676,6 +687,7 @@ ;; (.print System/out (prn-str 'branches* branches*)) ;; (.print System/out (prn-str '(:type branches*) (:type branches*))) (clojure.core.match/match (:type branches*) + ::char-tests branches* ::text-tests branches* ::tuple (do (assert (<= (count (:defaults branches*)) 1)) {:type ::tuple* @@ -710,6 +722,9 @@ :branches (:branches branches*)}))) get-vars (fn get-vars [pattern] (clojure.core.match/match pattern + [::&parser/char ?token] + '() + [::&parser/text ?text] '() @@ -730,6 +745,9 @@ )) ->instructions (fn ->instructions [locals pattern] (clojure.core.match/match pattern + [::&parser/char ?token] + [::pm-char ?token] + [::&parser/text ?text] [::pm-text ?text] @@ -801,6 +819,14 @@ [registers mappings tree] (exec [=branches (map-m (fn [[?pattern ?body]] ;; (prn '?branch ?branch) (match ?pattern + [::&parser/char ?token] + (exec [=body (analyse-form* ?body)] + (return [::case-branch [::&parser/char ?token] =body])) + + [::&parser/text ?token] + (exec [=body (analyse-form* ?body)] + (return [::case-branch [::&parser/text ?token] =body])) + [::&parser/ident ?name] (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])} (analyse-form* ?body))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 5b257eaed..ae8c75aa0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -318,17 +318,38 @@ (defn compile-decision-tree [writer mappings default-label decision-tree] ;; (prn 'compile-decision-tree decision-tree) (match decision-tree - [::test-text ?text $body] - (let [$else (new Label)] + [::test-char ?pairs] + (do (doseq [[?token $body] ?pairs + :let [$else (new Label)]] + (doto writer + ;; object + (.visitInsn Opcodes/DUP) ;; object, object + (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character")) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?token) ;; object, object, text + (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "" "(C)V") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B + (.visitJumpInsn Opcodes/IFEQ $else) ;; object + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel $else))) (doto writer - ;; object - (.visitInsn Opcodes/DUP) ;; object, object - (.visitLdcInsn ?text) ;; object, object, text - (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B - (.visitJumpInsn Opcodes/IFEQ $else) ;; object (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else) + (.visitJumpInsn Opcodes/GOTO default-label))) + + [::test-text ?pairs] + (do (doseq [[?text $body] ?pairs + :let [$else (new Label)]] + (doto writer + ;; object + (.visitInsn Opcodes/DUP) ;; object, object + (.visitLdcInsn ?text) ;; object, object, text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B + (.visitJumpInsn Opcodes/IFEQ $else) ;; object + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel $else))) + (doto writer (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO default-label))) @@ -427,12 +448,24 @@ ] [[::store ?local ?body] #{?body}]) + ::&analyser/char-tests + (concat (list [[::test-char (for [[?token ?supports] (:patterns head) + ?body (set/intersection branches ?supports) + ;; :when (set/subset? branches ?supports) + ] + [?token ?body])] + branches]) + (for [[_ ?local ?body] (:defaults head) + :when (contains? branches ?body)] + [[::store ?local ?body] #{?body}])) + ::&analyser/text-tests - (concat (for [[?text ?supports] (:patterns head) - ?body (set/intersection branches ?supports) - ;; :when (set/subset? branches ?supports) - ] - [[::test-text ?text ?body] #{?body}]) + (concat (list [[::test-text (for [[?token ?supports] (:patterns head) + ?body (set/intersection branches ?supports) + ;; :when (set/subset? branches ?supports) + ] + [?token ?body])] + branches]) (for [[_ ?local ?body] (:defaults head) :when (contains? branches ?body)] [[::store ?local ?body] #{?body}])) @@ -519,6 +552,7 @@ [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] (do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree) ;; (assert false) + ;; (prn 'compile-case ?decision-tree) (let [start-label (new Label) end-label (new Label) ;; default-label (new Label) @@ -539,24 +573,28 @@ ;; (prn 'sequence-parts ;; (sequence-parts (:branches ?decision-tree) (list ?decision-tree))) (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] - (if (:default ?decision-tree) + (if (or (:default ?decision-tree) + (not (empty? (:defaults ?decision-tree)))) (butlast pieces) pieces))] (compile-decision-tree *writer* mappings* default-label decision-tree)) (.visitLabel *writer* default-label) - (if-let [[_ [_ _ ?idx] ?body] (:default ?decision-tree)] + (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree) + (first (:defaults ?decision-tree)))] (doto *writer* (.visitInsn Opcodes/DUP) (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) (doto *writer* - ;; (.visitInsn Opcodes/POP) - (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+)) - (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String")) + (.visitInsn Opcodes/POP) + ;; (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+)) + ;; (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String")) (.visitTypeInsn Opcodes/NEW ex-class) - (.visitInsn Opcodes/DUP_X1) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "" (str "(" (->type-signature "java.lang.String") ")" "V")) + (.visitInsn Opcodes/DUP) + ;; (.visitInsn Opcodes/DUP_X1) + ;; (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "" "()V") + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "" (str "(" (->type-signature "java.lang.String") ")" "V")) (.visitInsn Opcodes/ATHROW))) ;; (if default-code ;; ;; (do (prn 'default-code default-code) -- cgit v1.2.3