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 ++++++++++++++++++++-------- test2.lux | 149 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 235 insertions(+), 22 deletions(-) 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) diff --git a/test2.lux b/test2.lux index e5e3ad6da..c3854ab19 100644 --- a/test2.lux +++ b/test2.lux @@ -269,6 +269,103 @@ outputs (map-m f inputs')] (return (#Cons output outputs))))) +(def (fold-m f init inputs) + (case inputs + #Nil (return init) + (#Cons x inputs') (exec [init* (f init x)] + (fold-m f init* inputs')))) + +(def (apply-m monad call-state) + (lambda [state] + (let output (monad call-state) + (case output + (#Ok [?state ?datum]) + (#Ok [state ?datum]) + + _ + output)))) + +(def (assert test message) + (if test + (return []) + (fail message))) + +(def (pass %value) + (lambda [state] + %value)) + +(def get-state + (lambda [state] + (return* state state))) + +(def (show x) + (jvm/invokevirtual Object "toString" [] + x [])) + +(def (concat t1 t2) + (jvm/invokevirtual String "concat" [String] + t1 [t2])) + +(def (normalize-char char) + (case char + #"*" "_ASTER_" + #"+" "_PLUS_" + #"-" "_DASH_" + #"/" "_SLASH_" + #"_" "_UNDERS_" + #"%" "_PERCENT_" + #"$" "_DOLLAR_" + #"'" "_QUOTE_" + #"`" "_BQUOTE_" + #"@" "_AT_" + #"^" "_CARET_" + #"&" "_AMPERS_" + #"=" "_EQ_" + #"!" "_BANG_" + #"?" "_QM_" + #":" "_COLON_" + #";" "_SCOLON_" + #"." "_PERIOD_" + #"," "_COMMA_" + #"<" "_LT_" + #">" "_GT_" + #"~" "_TILDE_" + ##;;#"\" "_BSLASH_" + _ (show char) + )) + +(def (range from to) + (if (= to from) + #Nil + (#Cons from (range (inc from) to)))) + +#( + (def (text->list text) + (let length (jvm/invokevirtual String "length" [] + text []) + (map (lambda [idx] + (jvm/invokevirtual String "charAt" [int] + text [idx])) + (range-to 0 length)))) + + (def (normalize-ident ident) + (fold concat "" (map normalize-char (text->list ident)))) + + (def (fresh-class-loader path) + (let file (jvm/new java.io.File [String] [path]) + (let url (jvm/invokevirtual java.io.File "toURL" [] + file []) + (let urls (array java.net.URL (list url)) + (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls]))))) + + (def (fresh-class-loader path) + (let [file (jvm/new java.io.File [String] [path]) + url (jvm/invokevirtual java.io.File "toURL" [] + file []) + urls (array java.net.URL (list url))] + (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls]))) + )# + (def (cons tail head) (#Cons head tail)) @@ -307,6 +404,53 @@ (def (run-state monad state) (monad state)) +(def list-map #Nil) + +(def (put key val map) + (case map + #Nil + (#Cons [key val] map) + + (#Cons [?key ?val] map') + (if (= key ?key) + (#Cons [?key val] map') + (#Cons [?key ?val] (put key val map'))))) + +(def (get key map) + (case map + #Nil + #None + + (#Cons [?key ?val] map') + (if (= key ?key) + (#Some ?val) + (get key map')))) + +(def (show-kv kv) + (case kv + [?key ?val] + (fold concat "" (list "#" ?key " " (show ?val))))) + +(def (interpose elem list) + (case list + (#Cons x (#Cons y list')) + (#Cons x (#Cons elem (#Cons y list'))) + + _ + list)) + +(def (print-map list-map) + (do (print "{") + (print (fold concat "" (interpose " " (map show-kv list-map)))) + (println "}"))) + +(def (show-list xs) + (case xs + #Nil + "#Nil" + (#Cons x xs') + (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) + ## Program (def (main args) (case (' ((~ "Oh yeah..."))) @@ -333,6 +477,11 @@ (#Failure ?message) (println ?message)) (print-enum (enumerate (list #"a" #"b" #"c" #"d" #"e"))) + (print-map (put "Nyan" "cat" (put "Yolo" "lol" list-map))) + (let char #"*" + (do (print (show char)) (print " -> ") + (println (normalize-char char)))) + (println (show-list (range 0 10))) ) )) -- cgit v1.2.3