aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorEduardo Julian2015-03-01 12:43:52 -0400
committerEduardo Julian2015-03-01 12:43:52 -0400
commit83a1a1510ca2e83711a80ff2eb961c5694306b9e (patch)
tree5ce5a13a61b771d27a64bd26c915fd54c75fa0a6 /src
parentb0d7e67b72fae763050b050d3452514db57ac682 (diff)
Almost done with the super refactoring.
Codebase still needs to be simplified further, though. Also, an explicit optimization phase, between analysis and compilation, must be established.
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj24
-rw-r--r--src/lux/analyser/lambda.clj4
-rw-r--r--src/lux/compiler/base.clj1
-rw-r--r--src/lux/compiler/case.clj706
-rw-r--r--src/lux/compiler/lux.clj15
5 files changed, 180 insertions, 570 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 06567423e..fccbb4377 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -36,7 +36,9 @@
(&&lux/analyse-tuple analyse-ast ?elems)
[::&parser/Tag ?tag]
- (return (list [::&&/Expression [::&&/variant ?tag (list)] [::&type/Variant {?tag [::&type/Tuple (list)]}]]))
+ (let [tuple-type [::&type/Tuple (list)]]
+ (return (list [::&&/Expression [::&&/variant ?tag [::&&/Expression [::&&/tuple (list)] tuple-type]]
+ [::&type/Variant (list [?tag tuple-type])]])))
[::&parser/Ident ?ident]
(&&lux/analyse-ident analyse-ast ?ident)
@@ -123,7 +125,8 @@
[::&parser/Form ([[::&parser/Ident "jvm;drem"] ?x ?y] :seq)]
(&&host/analyse-jvm-drem analyse-ast ?x ?y)
-
+
+ ;; Fields & methods
[::&parser/Form ([[::&parser/Ident "jvm;getstatic"] [::&parser/Ident ?class] [::&parser/Ident ?field]] :seq)]
(&&host/analyse-jvm-getstatic analyse-ast ?class ?field)
@@ -135,7 +138,8 @@
[::&parser/Form ([[::&parser/Ident "jvm;invokevirtual"] [::&parser/Ident ?class] [::&parser/Text ?method] [::&parser/Tuple ?classes] ?object [::&parser/Tuple ?args]] :seq)]
(&&host/analyse-jvm-invokevirtual analyse-ast ?class ?method ?classes ?object ?args)
-
+
+ ;; Arrays
[::&parser/Form ([[::&parser/Ident "jvm;new"] [::&parser/Ident ?class] [::&parser/Tuple ?classes] [::&parser/Tuple ?args]] :seq)]
(&&host/analyse-jvm-new analyse-ast ?class ?classes ?args)
@@ -148,6 +152,7 @@
[::&parser/Form ([[::&parser/Ident "jvm;aaload"] ?array [::&parser/Int ?idx]] :seq)]
(&&host/analyse-jvm-aaload analyse-ast ?array ?idx)
+ ;; Classes & interfaces
[::&parser/Form ([[::&parser/Ident "jvm;class"] [::&parser/Ident ?name] [::&parser/Ident ?super-class] [::&parser/Tuple ?fields]] :seq)]
(&&host/analyse-jvm-class analyse-ast ?name ?super-class ?fields)
@@ -155,15 +160,16 @@
(&&host/analyse-jvm-interface analyse-ast ?name ?members)
_
- (fail (str "[Analyser Error] Unmatched token: " token))))
+ (fail (str "[Analyser Error] Unmatched token: " (pr-str token)))))
(defn ^:private analyse-ast [token]
(match token
- [::&parser/Form ([[::&parser/Tag ?tag] & ?data] :seq)]
- (exec [=data (mapcat-m analyse-ast ?data)
- :let [_ (prn '=data =data)]
- =data-types (map-m &&/expr-type =data)]
- (return (list [::&&/Expression [::&&/variant ?tag =data] [::&type/Variant {?tag [::&type/Tuple =data-types]}]])))
+ [::&parser/Form ([[::&parser/Tag ?tag] & ?values] :seq)]
+ (exec [_ (assert! (= 1 (count ?values)) "[Analyser Error] Can only tag 1 value.")
+ :let [?value (first ?values)]
+ =value (&&/analyse-1 analyse-ast ?value)
+ =value-type (&&/expr-type =value)]
+ (return (list [::&&/Expression [::&&/variant ?tag =value] [::&type/Variant (list [?tag =value-type])]])))
[::&parser/Form ([?fn & ?args] :seq)]
(try-all-m [(&&lux/analyse-call analyse-ast ?fn ?args)
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index be7000acd..b20eb8e19 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -46,8 +46,8 @@
[::&&/tuple ?members]
[::&&/Expression [::&&/tuple (map (partial raise-expr arg) ?members)] ?type]
- [::&&/variant ?tag ?members]
- [::&&/Expression [::&&/variant ?tag (map (partial raise-expr arg) ?members)] ?type]
+ [::&&/variant ?tag ?value]
+ [::&&/Expression [::&&/variant ?tag (raise-expr arg ?value)] ?type]
[::&&/local ?idx]
[::&&/Expression [::&&/local (inc ?idx)] ?type]
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 28c793e10..39c67f5d0 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -13,6 +13,7 @@
(def local-prefix "l")
(def partial-prefix "p")
(def closure-prefix "c")
+(def tuple-field-prefix "_")
(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;")
(defn add-nulls [writer amount]
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 0f49c08b5..ba27d2c12 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -18,580 +18,186 @@
MethodVisitor)))
;; [Utils]
-(defn ^:private map-branches [idx mappings patterns]
- (reduce (fn [[idx mappings patterns*] [test body]]
- [(inc idx)
- (assoc mappings idx body)
- (cons [test idx] patterns*)])
- [idx mappings (list)]
- patterns))
-
-(defn ^:private map-bodies [pm-struct]
- (match pm-struct
- [::BoolPM ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::BoolPM patterns* defaults*]])
-
- [::IntPM ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::IntPM patterns* defaults*]])
-
- [::RealPM ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::RealPM patterns* defaults*]])
-
- [::CharPM ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::CharPM patterns* defaults*]])
-
- [::TextPM ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::TextPM patterns* defaults*]])
-
- [::TuplePM ?num-elems ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::TuplePM ?num-elems patterns* defaults*]])
-
- [::VariantPM ?tags ?patterns ?defaults]
- (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
- [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
- [mappings* [::VariantPM ?tags patterns* defaults*]])
-
- [::?PM ?defaults]
- (let [[_ mappings defaults*] (map-branches 0 {} ?defaults)]
- [mappings [::?PM defaults*]])))
-
-(defn ^:private get-default [pm-struct]
- (match pm-struct
- [::BoolPM ?patterns ?defaults]
- (first ?defaults)
-
- [::IntPM ?patterns ?defaults]
- (first ?defaults)
-
- [::RealPM ?patterns ?defaults]
- (first ?defaults)
-
- [::CharPM ?patterns ?defaults]
- (first ?defaults)
-
- [::TextPM ?patterns ?defaults]
- (first ?defaults)
-
- [::TuplePM ?num-elems ?patterns ?defaults]
- (first ?defaults)
-
- [::VariantPM ?tags ?patterns ?defaults]
- (first ?defaults)
-
- [::?PM ?defaults]
- (first ?defaults)
- ))
-
-(do-template [<name> <wrapper-class> <value-method> <method-sig>]
- (defn <name> [writer mappings $default ?patterns]
- (doseq [[?token $body] ?patterns
- :let [$else (new Label)]]
- (doto writer
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <wrapper-class>) <value-method> <method-sig>)
- (.visitLdcInsn ?token)
- (.visitJumpInsn Opcodes/IF_ICMPNE $else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $default)))
-
- ^:private compile-bool-pm "java.lang.Boolean" "booleanValue" "()Z"
- ^:private compile-char-pm "java.lang.Character" "charValue" "()C"
- )
-
-(do-template [<name> <wrapper-class> <value-method> <method-sig> <cmp-op>]
- (defn <name> [writer mappings $default ?patterns]
- (doseq [[?token $body] ?patterns
- :let [$else (new Label)]]
- (doto writer
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <wrapper-class>) <value-method> <method-sig>)
- (.visitLdcInsn ?token)
- (.visitInsn <cmp-op>)
- (.visitJumpInsn Opcodes/IFNE $else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $default)))
-
- ^:private compile-int-pm "java.lang.Long" "longValue" "()J" Opcodes/LCMP
- ^:private compile-real-pm "java.lang.Double" "doubleValue" "()D" Opcodes/DCMPL
- )
-
-(defn ^:private compile-text-pm [writer mappings $default ?patterns]
- (doseq [[?token $body] ?patterns
- :let [$else (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?token)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z"))
- (.visitJumpInsn Opcodes/IFEQ $else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $default)))
-
-(defn ^:private compile-tuple-pm [writer mapping $default ?num-elems ?patterns]
- (let [sub-patterns (map (fn [idx]
- (map (fn [tup body]
- [(nth tup idx) body])
- ?patterns))
- (range ?num-elems))
- ;; subpm-structs (map group-patterns sub-patterns)
- ;; [pat-h & pat-t] subpm-structs
- ;; (for [(get-branches pat-h)
- ;; (cull pat-t)]
- ;; )
- ;; (reduce (fn [branches pattern]
- ;; ( (group-patterns pattern)))
- ;; (get-branches pat-h)
- ;; pat-t)
- ]
- ;; (sequence-tests sub-patterns)
- ))
-
-(let [+tag-sig+ (&host/->type-signature "java.lang.String")
- variant-class* (&host/->class &host/variant-class)
- tuple-class* (&host/->class &host/tuple-class)
- +variant-field-sig+ (&host/->type-signature "java.lang.Object")
- oclass (&host/->class "java.lang.Object")
- equals-sig (str "(" (&host/->type-signature "java.lang.Object") ")Z")]
- (defn ^:private compile-decision-tree [writer mappings default-label decision-tree]
- (match decision-tree
- [::test-bool ?pairs]
- (compile-bool-pm writer mappings default-label ?pairs)
-
- [::test-int ?pairs]
- (compile-int-pm writer mappings default-label ?pairs)
-
- [::test-real ?pairs]
- (compile-real-pm writer mappings default-label ?pairs)
-
- [::test-char ?pairs]
- (compile-char-pm writer mappings default-label ?pairs)
-
- [::test-text ?pairs]
- (compile-text-pm writer mappings default-label ?pairs)
-
- [::store ?idx $body]
- (doto writer
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body)))
-
- [::test-tuple ?branches ?cases]
- (let [[_ ?subcases] (first ?cases)
- arity (-> ?subcases first (nth 2) count)
- tuple-class** (str tuple-class* arity)]
- (doto writer
- ;; object
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple
- (do (doseq [subcase ?subcases
- :let [next-subcase (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [sub-next-elem (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; tuple, tuple
- (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str &&/partial-prefix ?subidx) +variant-field-sig+) ;; tuple, object
- (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple
- (.visitLabel sub-next-elem)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel next-subcase)))
- )))
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
- [::test-variant ?branches ?cases]
- (doto writer
- ;; object
- (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
- (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
- (.visitLdcInsn ?tag) ;; variant, tag, tag, text
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
- (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
- (.visitInsn Opcodes/POP) ;; variant
- (do (let [arity (-> ?subcases first (nth 2) count)
- variant-class** (str variant-class* arity)]
- (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN
- (doseq [subcase ?subcases
- :let [next-subcase (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [sub-next-elem (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class** (str &&/partial-prefix ?subidx) +variant-field-sig+) ;; variant, object
- (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant
- (.visitLabel sub-next-elem)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel next-subcase)))
- ))
- ))
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)
- ;; variant, tag ->
- (.visitLabel tag-else-label))
- (->> (doseq [[?tag ?subcases] ?cases
- :let [tag-else-label (new Label)]])))
- ;; variant, tag ->
- (.visitInsn Opcodes/POP) ;; variant ->
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)))
- ))
-
-(defn ^:private compile-pm [writer mapping pm-struct $default]
- (match pm-struct
- [::BoolPM ?patterns ?defaults]
- (compile-bool-pm writer mapping $default ?patterns)
-
- [::IntPM ?patterns ?defaults]
- (compile-int-pm writer mapping $default ?patterns)
-
- [::RealPM ?patterns ?defaults]
- (compile-real-pm writer mapping $default ?patterns)
-
- [::CharPM ?patterns ?defaults]
- (compile-char-pm writer mapping $default ?patterns)
-
- [::TextPM ?patterns ?defaults]
- (compile-text-pm writer mapping $default ?patterns)
-
- [::TuplePM ?num-elems ?patterns ?defaults]
- (compile-tuple-pm writer mapping $default ?num-elems ?patterns)
-
- [::VariantPM ?tags ?patterns ?defaults]
- (first ?defaults)
+(defn ^:private ->match [$body register token]
+ (match token
+ [::&parser/Ident ?name]
+ [(inc register) [::Pattern $body [::StoreMatch register]]]
- [::?PM ?defaults]
- (first ?defaults)
- ))
-
-(do-template [<name> <pm-tag>]
- (defn <name> [pm value body]
- (match pm
- [<pm-tag> ?branches ?defaults]
- (return [<pm-tag> (cons [value body] ?branches) ?defaults])
-
- [::?PM ?defaults]
- (return [<pm-tag> (list [value body]) ?defaults])
-
- _
- (fail "Can't match pattern!")))
-
- ^:private group-bool-pm ::BoolPM
- ^:private group-int-pm ::IntPM
- ^:private group-real-pm ::RealPM
- ^:private group-char-pm ::CharPM
- ^:private group-text-pm ::textPM
- )
-
-(defn ^:private group-branch [pm [pattern body]]
- (match pattern
[::&parser/Bool ?value]
- (group-bool-pm pm ?value body)
+ [register [::Pattern $body [::BoolMatch ?value]]]
[::&parser/Int ?value]
- (group-int-pm pm ?value body)
+ [register [::Pattern $body [::IntMatch ?value]]]
[::&parser/Real ?value]
- (group-real-pm pm ?value body)
+ [register [::Pattern $body [::RealMatch ?value]]]
[::&parser/Char ?value]
- (group-char-pm pm ?value body)
+ [register [::Pattern $body [::CharMatch ?value]]]
[::&parser/Text ?value]
- (group-text-pm pm ?value body)
-
- [::&parser/Tuple ?members]
- (match pm
- [::TuplePM ?num-elems ?branches ?defaults]
- (exec [_ (&/assert! (= ?num-elems (count ?members))
- (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))]
- (return [::TuplePM ?num-elems (cons [?members body] ?branches) ?defaults]))
-
- [::?PM ?defaults]
- (return [::TuplePM (count ?members) (list [?members body]) ?defaults])
+ [register [::Pattern $body [::TextMatch ?value]]]
- _
- (fail "Can't match pattern!"))
+ [::&parser/Tuple ?members]
+ (let [[register* =members] (reduce (fn [[register =members] member]
+ (let [[register* =member] (->match $body register member)]
+ [register* (cons =member =members)]))
+ [register (list)] ?members)]
+ [register* [::Pattern $body [::TupleMatch (reverse =members)]]])
[::&parser/Tag ?tag]
- (let [members (list)
- num-members (count members)]
- (match pm
- [::VariantPM ?variants ?branches ?defaults]
- (exec [variants* (if-let [?num-elems (get ?variants ?tag)]
- (exec [_ (&/assert! (= ?num-elems num-members)
- (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
- (return ?variants))
- (return (assoc ?variants ?tag num-members)))]
- (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
-
- [::?PM ?defaults]
- (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults])
-
- _
- (fail "Can't match pattern!")))
-
- [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)]
- (let [members ?members
- num-members (count members)]
- (match pm
- [::VariantPM ?variants ?branches ?defaults]
- (exec [variants* (if-let [?num-elems (get ?variants ?tag)]
- (exec [_ (&/assert! (= ?num-elems num-members)
- (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
- (return ?variants))
- (return (assoc ?variants ?tag num-members)))]
- (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
-
- [::?PM ?defaults]
- (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults])
-
- _
- (fail "Can't match pattern!")))
-
- [::&parser/Ident ?name]
- (match pm
- [::BoolPM ?patterns ?defaults]
- (return [::BoolPM ?patterns (conj ?defaults [?name body])])
-
- [::IntPM ?patterns ?defaults]
- (return [::IntPM ?patterns (conj ?defaults [?name body])])
-
- [::RealPM ?patterns ?defaults]
- (return [::RealPM ?patterns (conj ?defaults [?name body])])
-
- [::CharPM ?patterns ?defaults]
- (return [::CharPM ?patterns (conj ?defaults [?name body])])
+ [register [::Pattern $body [::VariantMatch ?tag [::Pattern $body [::TupleMatch (list)]]]]]
- [::TextPM ?patterns ?defaults]
- (return [::TextPM ?patterns (conj ?defaults [?name body])])
-
- [::TuplePM ?num-elems ?patterns ?defaults]
- (return [::TuplePM ?num-elems ?patterns (conj ?defaults [?name body])])
-
- [::VariantPM ?tags ?patterns ?defaults]
- (return [::VariantPM ?tags ?patterns (conj ?defaults [?name body])])
+ [::&parser/Form ([[::&parser/Tag ?tag] ?value] :seq)]
+ (let [[register* =value] (->match $body register ?value)]
- [::?PM ?defaults]
- (return [::?PM (conj ?defaults [?name body])]))
+ [register* [::Pattern $body [::VariantMatch ?tag =value]]])
))
-(defn ^:private valid-paths [group]
- (set (match group
- [::BoolPM ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::IntPM ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::RealPM ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::CharPM ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::TextPM ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::TuplePM ?num-elems ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::VariantPM ?tags ?patterns ?defaults]
- (concat (map second ?patterns) (map second ?defaults))
-
- [::?PM ?defaults]
- (map second ?defaults))))
-
-(defn ^:private sequence-multi-pm [sequence-pm prev-paths groups]
- (match groups
- ([head & tail] :seq)
- (let [curr-paths (set/intersection prev-paths (valid-paths head))]
- (for [[head-paths head-test] (sequence-pm curr-paths head)]
- [:multi-test head-test head-paths (sequence-multi-pm sequence-pm head-paths tail)]))
-
- _
- (list (list))))
-
-(do-template [<name> <pm> <test>]
- (defn <name> [prev-paths group]
- (match group
- [<pm> ?patterns ?defaults]
- (return (concat (for [[value $body] ?patterns
- :when (contains? prev-paths $body)]
- [<test> value #{$body}])
- (match ?defaults
- ([[default-register $body] & _] :seq)
- (list [<test> default-register #{$body}])
-
- :else
- (list))))
-
- :else
- (fail "")))
-
- ^:private sequence-bool ::BoolPM ::test-bool
- ^:private sequence-int ::IntPM ::test-int
- ^:private sequence-real ::RealPM ::test-real
- ^:private sequence-char ::CharPM ::test-char
- ^:private sequence-text ::TextPM ::test-text
- )
+(defn ^:private process-branches [base-register branches]
+ (let [[_ mappings pms] (reduce (fn [[$id mappings =matches] [pattern body]]
+ (let [[_ =match] (->match $id base-register pattern)]
+ [(inc $id) (assoc mappings $id body) (cons =match =matches)]))
+ [0 {} (list)]
+ branches)]
+ [mappings (reverse pms)]))
-(defn ^:private sequence-? [group]
- (match group
- [::?PM ([[default-register $body] & _] :seq)]
- (return (list [::test-store default-register #{$body}]))
-
- :else
- (fail "")))
-
-(defn ^:private sequence-pm [group]
- (match group
- [::BoolPM _ _]
- (sequence-bool group)
-
- [::IntPM _ _]
- (sequence-int group)
+(let [+tag-sig+ (&host/->type-signature "java.lang.String")
+ +variant-class+ (&host/->class &host/variant-class)
+ tuple-class* (&host/->class &host/tuple-class)
+ +variant-value-sig+ (&host/->type-signature "java.lang.Object")
+ +oclass+ (&host/->class "java.lang.Object")
+ +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")]
+ (defn ^:private compile-match [writer ?match $target $else]
+ (match ?match
+ [::StoreMatch ?register]
+ (doto writer
+ (.visitVarInsn Opcodes/ASTORE ?register)
+ (.visitJumpInsn Opcodes/GOTO $target))
- [::RealPM _ _]
- (sequence-real group)
+ [::BoolMatch ?value]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z")
+ (.visitLdcInsn ?value)
+ (.visitJumpInsn Opcodes/IF_ICMPNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
- [::CharPM _ _]
- (sequence-char group)
+ [::IntMatch ?value]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J")
+ (.visitLdcInsn ?value)
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
- [::TextPM _ _]
- (sequence-text group)
+ [::RealMatch ?value]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D")
+ (.visitLdcInsn ?value)
+ (.visitInsn Opcodes/DCMPL)
+ (.visitJumpInsn Opcodes/IFNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
- [::?PM _]
- (sequence-? group)
+ [::CharMatch ?value]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C")
+ (.visitLdcInsn ?value)
+ (.visitJumpInsn Opcodes/IF_ICMPNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
- [::TuplePM ?num-elems ?patterns ?defaults]
- (exec [:let [sub-patterns (map (fn [idx]
- (map (fn [[tup body]]
- [(nth tup idx) body])
- ?patterns))
- (range ?num-elems))]
- groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns)
- tuple-paths (valid-paths group)
- sub-seqs (sequence-multi-pm sequence-pm tuple-paths groups)]
- (return (cons [::test-tuple ?num-elems sub-seqs]
- (match ?defaults
- ([[default-register $body] & _] :seq)
- (list [::test-store default-register #{$body}])
-
- :else
- (list)))))
+ [::TextMatch ?value]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?value)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z"))
+ (.visitJumpInsn Opcodes/IFEQ $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
- [::VariantPM ?tags ?patterns ?defaults]
- (map-m (fn [tag]
- (exec [:let [?num-elems (get ?tags tag)
- members+bodies (mapcat (fn [[ptag pmembers pbody]]
- (if (= ptag tag)
- (list [pmembers pbody])
- (list)))
- ?patterns)
- sub-patterns (map (fn [idx]
- (map (fn [[tup body]]
- [(nth tup idx) body])
- members+bodies))
- (range ?num-elems))]
- groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns)
- tag-paths (set (map second members+bodies))
- sub-seqs (sequence-multi-pm sequence-pm tag-paths groups)]
- (cons [::test-variant tag ?num-elems sub-seqs]
- (match ?defaults
- ([[default-register $body] & _] :seq)
- (list [::test-store default-register #{$body}])
-
- :else
- (list)))))
- (keys ?tags))
- ))
+ [::TupleMatch ?members]
+ (let [tuple-class** (str tuple-class* (count ?members))]
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class**)
+ (-> (doto (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str &&/tuple-field-prefix idx) +variant-value-sig+)
+ (compile-match member $next $sub-else)
+ (.visitLabel $sub-else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $else)
+ (.visitLabel $next))
+ (->> (doseq [[idx [_ _ member]] (map vector (range (count ?members)) ?members)
+ :let [$next (new Label)
+ $sub-else (new Label)]])))
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target)))
+
+ [::VariantMatch ?tag [::Pattern _ ?value]]
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST +variant-class+)
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD +variant-class+ "tag" +tag-sig+)
+ (.visitLdcInsn ?tag)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +oclass+ "equals" +equals-sig+)
+ (.visitJumpInsn Opcodes/IFEQ $else)
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD +variant-class+ "value" +variant-value-sig+)
+ (-> (doto (compile-match ?value $target $value-else)
+ (.visitLabel $value-else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $else))
+ (->> (let [$value-else (new Label)]))))
+ )))
-(defn ^:private decision-tree [branches]
- (prn 'decision-tree branches)
- (exec [group (reduce-m group-branch [::?PM (list)] branches)
- :let [[mappings group*] (map-bodies group)
- paths (valid-paths group*)]]
- (sequence-pm group*)))
+(let [ex-class (&host/->class "java.lang.IllegalStateException")]
+ (defn ^:private compile-pattern-matching [writer compile mappings patterns $end]
+ (let [entries (for [[?branch ?body] mappings
+ :let [label (new Label)]]
+ [[?branch label]
+ [label ?body]])
+ mappings* (into {} (map first entries))]
+ (doto writer
+ (-> (doto (compile-match ?match (get mappings* ?body) $else)
+ (.visitLabel $else))
+ (->> (doseq [[_ ?body ?match :as pattern] patterns
+ :let [_ (prn 'compile-pattern-matching/pattern pattern)
+ $else (new Label)]])))
+ (.visitInsn Opcodes/POP)
+ (.visitTypeInsn Opcodes/NEW ex-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW))
+ (map-m (fn [[?label ?body]]
+ (exec [:let [_ (do (.visitLabel writer ?label)
+ (.visitInsn writer Opcodes/POP))]
+ ret (compile ?body)
+ :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
+ (return ret)))
+ (map second entries))
+ )))
;; [Resources]
-(let [ex-class (&host/->class "java.lang.IllegalStateException")]
- (defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
- (exec [*writer* &/get-writer
- :let [_ (prn "Has writer")]
- :let [$start (new Label)
- $end (new Label)
- _ (dotimes [offset ?num-registers]
- (let [idx (+ ?base-register offset)]
- (.visitLocalVariable *writer* (str &&/local-prefix idx) (&host/->java-sig [::&type/Any]) nil $start $end idx)))]
- :let [_ (prn "PRE Compiled ?variant")]
- _ (compile ?variant)
- :let [_ (prn "POST Compiled ?variant")]
- :let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLabel $start))]
- [mapping tree] (decision-tree ?branches)
- :let [_ (assert false "compile-case")]
-
- ;; :let [[mappings pm-struct*] (map-bodies pm-struct)
- ;; entries (for [[?branch ?body] mappings
- ;; :let [label (new Label)]]
- ;; [[?branch label]
- ;; [label ?body]])
- ;; mappings* (into {} (map first entries))
- ;; ]
- ;; :let [$default (new Label)
- ;; _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts ?pm-struct))]
- ;; (if (get-default pm-struct)
- ;; (butlast pieces)
- ;; pieces))]
- ;; (compile-decision-tree *writer* mappings* $default decision-tree))
- ;; (.visitLabel *writer* $default)
- ;; (if-let [[?idx ?body] (get-default pm-struct)]
- ;; (doto *writer*
- ;; (.visitInsn Opcodes/DUP)
- ;; (.visitVarInsn Opcodes/ASTORE ?idx)
- ;; (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
- ;; (doto *writer*
- ;; (.visitInsn Opcodes/POP)
- ;; (.visitTypeInsn Opcodes/NEW ex-class)
- ;; (.visitInsn Opcodes/DUP)
- ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- ;; (.visitInsn Opcodes/ATHROW))))]
- ;; _ (map-m (fn [[?label ?body]]
- ;; (exec [:let [_ (do (.visitLabel *writer* ?label)
- ;; (.visitInsn *writer* Opcodes/POP))]
- ;; ret (compile ?body)
- ;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
- ;; (return ret)))
- ;; (map second entries))
- ;; :let [_ (.visitLabel *writer* $end)]
- ]
- (return nil))))
+(defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
+ (exec [*writer* &/get-writer
+ :let [$start (new Label)
+ $end (new Label)
+ _ (dotimes [offset ?num-registers]
+ (let [idx (+ ?base-register offset)]
+ (.visitLocalVariable *writer* (str &&/local-prefix idx) (&host/->java-sig [::&type/Any]) nil $start $end idx)))]
+ _ (compile ?variant)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLabel $start))]
+ :let [_ (prn "PRE Compiled ?branches")]
+ :let [[mappings patterns] (process-branches ?base-register ?branches)]
+ _ (compile-pattern-matching *writer* compile mappings patterns $end)
+ :let [_ (prn "POST Compiled ?branches")]
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil)))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 4635bfa1a..81d68c31c 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -93,22 +93,19 @@
(range num-elems))]
(return nil)))
-(defn compile-variant [compile *type* ?tag ?members]
+(defn compile-variant [compile *type* ?tag ?value]
(exec [*writer* &/get-writer
- :let [variant-class* (str (&host/->class &host/variant-class) (count ?members))
+ :let [variant-class* (&host/->class &host/variant-class)
_ (doto *writer*
(.visitTypeInsn Opcodes/NEW variant-class*)
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn ?tag)
- (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (&host/->type-signature "java.lang.String")))]
- _ (map-m (fn [[?tfield ?member]]
- (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
- ret (compile ?member)
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str &&/partial-prefix ?tfield) "Ljava/lang/Object;")]]
- (return ret)))
- (map vector (range (count ?members)) ?members))]
+ (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (&host/->type-signature "java.lang.String"))
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?value)
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* "value" (&host/->type-signature "java.lang.Object"))]]
(return nil)))
(defn compile-local [compile *type* ?idx]