aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux469
-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
6 files changed, 426 insertions, 793 deletions
diff --git a/source/lux.lux b/source/lux.lux
index f11e8031b..8c1cb5695 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -34,193 +34,163 @@
[java.lang.Object _7] [java.lang.Object _8]])
(jvm;class Variant java.lang.Object
- [[java.lang.String tag]])
-(jvm;class Variant0 lux.Variant
- [])
-(jvm;class Variant1 lux.Variant
- [[java.lang.Object _1]])
-(jvm;class Variant2 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]])
-(jvm;class Variant3 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]
- [java.lang.Object _3]])
-(jvm;class Variant4 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]
- [java.lang.Object _3] [java.lang.Object _4]])
-(jvm;class Variant5 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]
- [java.lang.Object _3] [java.lang.Object _4]
- [java.lang.Object _5]])
-(jvm;class Variant6 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]
- [java.lang.Object _3] [java.lang.Object _4]
- [java.lang.Object _5] [java.lang.Object _6]])
-(jvm;class Variant7 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]
- [java.lang.Object _3] [java.lang.Object _4]
- [java.lang.Object _5] [java.lang.Object _6]
- [java.lang.Object _7]])
-(jvm;class Variant8 lux.Variant
- [[java.lang.Object _1] [java.lang.Object _2]
- [java.lang.Object _3] [java.lang.Object _4]
- [java.lang.Object _5] [java.lang.Object _6]
- [java.lang.Object _7] [java.lang.Object _8]])
+ [[java.lang.String tag] [java.lang.Object value]])
## Base functions & macros
(def' let'
(lambda' _ tokens
(lambda' _ state
(case' tokens
- (#Cons lhs (#Cons rhs (#Cons body #Nil)))
- [(#Cons (#Form (#Cons (#Ident "case'") (#Cons rhs (#Cons lhs (#Cons body #Nil)))))
- #Nil)
+ (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
+ [(#Cons [(#Form (#Cons [(#Ident "case'") (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
+ #Nil])
state])
)))
-(def' lambda
- (lambda' _ tokens
- (lambda' _ state
- (let' output (case' tokens
- (#Cons (#Form (#Cons self (#Cons arg args'))) (#Cons body #Nil))
- (#Form (#Cons (#Ident "lambda'")
- (#Cons self
- (#Cons arg
- (#Cons (case args'
- #Nil
- body
-
- _
- (#Form (#Cons (#Ident "lux;lambda")
- (#Cons (#Form (#Cons (#Ident "_") args'))
- (#Cons body #Nil)))))
- #Nil))))))
- [(#Cons output #Nil) state])
- )))
-(declare-macro lambda)
-
-(def' def
- (lambda (_ tokens state)
- (let' output (case' tokens
- (#Cons (#Ident name) (#Cons body #Nil))
- (#Form (#Cons (#Ident "def'")
- (#Cons (#Ident name)
- (#Cons body #Nil))))
-
- (#Cons (#Form (#Cons (#Ident name) args))
- (#Cons body #Nil))
- (#Form (#Cons (#Ident "def'")
- (#Cons (#Ident name)
- (#Cons (#Form (#Cons (#Ident "lux:lambda")
- (#Cons (#Form (#Cons (#Ident name) args))
- (#Cons body #Nil))))
- #Nil)))))
- [(#Cons output #Nil) state])))
-(declare-macro def)
-
-(def (comment tokens state)
- [#Nil state])
-(declare-macro comment)
-
-(def (+ x y)
- (jvm;iadd x y))
-
-(def (id x)
- x)
-
-(def (print x)
- (jvm;invokevirtual java.io.PrintStream "print" [Object]
- (jvm;getstatic System out) [x]))
-
-(def (println x)
- (jvm;invokevirtual java.io.PrintStream "println" [Object]
- (jvm;getstatic System out) [x]))
-
-(def (fold f init xs)
- (do (print "fold ") (print init) (print " ") (println xs)
- (case' xs
- #Nil
- init
+## (def' lambda
+## (lambda' _ tokens
+## (lambda' _ state
+## (let' output (case' tokens
+## (#Cons [(#Form (#Cons [self (#Cons [arg args'])])) (#Cons [body #Nil])])
+## (#Form (#Cons [(#Ident "lambda'")
+## (#Cons [self
+## (#Cons [arg
+## (#Cons [(case args'
+## #Nil
+## body
+
+## _
+## (#Form (#Cons [(#Ident "lux;lambda")
+## (#Cons [(#Form (#Cons [(#Ident "_") args']))
+## (#Cons [body #Nil])])])))
+## #Nil])])])])))
+## [(#Cons output #Nil) state])
+## )))
+## (declare-macro lambda)
+
+## (def' def
+## (lambda (_ tokens state)
+## (let' output (case' tokens
+## (#Cons (#Ident name) (#Cons body #Nil))
+## (#Form (#Cons (#Ident "def'")
+## (#Cons (#Ident name)
+## (#Cons body #Nil))))
+
+## (#Cons (#Form (#Cons (#Ident name) args))
+## (#Cons body #Nil))
+## (#Form (#Cons (#Ident "def'")
+## (#Cons (#Ident name)
+## (#Cons (#Form (#Cons (#Ident "lux:lambda")
+## (#Cons (#Form (#Cons (#Ident name) args))
+## (#Cons body #Nil))))
+## #Nil)))))
+## [(#Cons output #Nil) state])))
+## (declare-macro def)
+
+## (def (comment tokens state)
+## [#Nil state])
+## (declare-macro comment)
+
+## (def (+ x y)
+## (jvm;iadd x y))
+
+## (def (id x)
+## x)
+
+## (def (print x)
+## (jvm;invokevirtual java.io.PrintStream "print" [Object]
+## (jvm;getstatic System out) [x]))
+
+## (def (println x)
+## (jvm;invokevirtual java.io.PrintStream "println" [Object]
+## (jvm;getstatic System out) [x]))
+
+## (def (fold f init xs)
+## (do (print "fold ") (print init) (print " ") (println xs)
+## (case' xs
+## #Nil
+## init
- (#Cons x xs')
- (let' init' (f init x)
- (do (print "init': ") (println init')
- (fold f init' xs')))
- #((fold f (f init x) xs'))#
- )))
-
-(def (reverse list)
- (do (print "reverse ") (println list)
- (let' reversed (fold (lambda [tail head]
- (do (print "reverse/0 ") (print "tail: ") (print tail) (print " head: ") (println head)
- (#Cons head tail)))
- #Nil
- list)
- (do (print "!reversed ") (println reversed)
- reversed))))
-
-(def (list xs state)
- (let' xs' (reverse xs)
- (let' output (fold (lambda [tail head]
- (do (print "tail: ") (print tail) (print " head: ") (println head)
- (#Form (#Cons (#Tag "Cons")
- (#Cons head
- (#Cons tail #Nil))))))
- (#Tag "Nil")
- (do (print "REVERSED: ") (println xs')
- xs'))
- (do (print "output: ") (println output)
- [(#Cons output #Nil) state]))))
-(declare-macro list)
-
-(def (list+ xs state)
- (case' (reverse xs)
- #Nil
- [#Nil state]
-
- (#Cons last init')
- (let' output (fold (lambda [tail head]
- (#Form (#Cons (#Tag "Cons")
- (#Cons head tail))))
- last
- init')
- [(#Cons output #Nil) state])))
-(declare-macro list+)
-
-(def (->pairs xs)
- (case' xs
- (#Cons x (#Cons y xs'))
- (#Cons [x y] (->pairs xs'))
-
- _
- #Nil))
-
-(def (let tokens state)
- (case' tokens
- (#Cons (#Tuple bindings) (#Cons body #Nil))
- (let' output (fold (lambda [body binding]
- (case binding
- [label value]
- (#Form (list (#Ident "let'") label value body))))
- body
- (reverse (->pairs bindings)))
- [(list output) state])))
-(declare-macro let)
-
-(def (++-list xs ys)
- (case' xs
- #Nil
- ys
-
- (#Cons x xs*)
- (#Cons x (++-list xs* ys))))
-
-(def (map-list f xs)
- (case' xs
- #Nil
- #Nil
-
- (#Cons x xs*)
- (#Cons (f x) (map-list f xs*))))
+## (#Cons x xs')
+## (let' init' (f init x)
+## (do (print "init': ") (println init')
+## (fold f init' xs')))
+## #((fold f (f init x) xs'))#
+## )))
+
+## (def (reverse list)
+## (do (print "reverse ") (println list)
+## (let' reversed (fold (lambda [tail head]
+## (do (print "reverse/0 ") (print "tail: ") (print tail) (print " head: ") (println head)
+## (#Cons head tail)))
+## #Nil
+## list)
+## (do (print "!reversed ") (println reversed)
+## reversed))))
+
+## (def (list xs state)
+## (let' xs' (reverse xs)
+## (let' output (fold (lambda [tail head]
+## (do (print "tail: ") (print tail) (print " head: ") (println head)
+## (#Form (#Cons (#Tag "Cons")
+## (#Cons head
+## (#Cons tail #Nil))))))
+## (#Tag "Nil")
+## (do (print "REVERSED: ") (println xs')
+## xs'))
+## (do (print "output: ") (println output)
+## [(#Cons output #Nil) state]))))
+## (declare-macro list)
+
+## (def (list+ xs state)
+## (case' (reverse xs)
+## #Nil
+## [#Nil state]
+
+## (#Cons last init')
+## (let' output (fold (lambda [tail head]
+## (#Form (#Cons (#Tag "Cons")
+## (#Cons head tail))))
+## last
+## init')
+## [(#Cons output #Nil) state])))
+## (declare-macro list+)
+
+## (def (->pairs xs)
+## (case' xs
+## (#Cons x (#Cons y xs'))
+## (#Cons [x y] (->pairs xs'))
+
+## _
+## #Nil))
+
+## (def (let tokens state)
+## (case' tokens
+## (#Cons (#Tuple bindings) (#Cons body #Nil))
+## (let' output (fold (lambda [body binding]
+## (case binding
+## [label value]
+## (#Form (list (#Ident "let'") label value body))))
+## body
+## (reverse (->pairs bindings)))
+## [(list output) state])))
+## (declare-macro let)
+
+## (def (++-list xs ys)
+## (case' xs
+## #Nil
+## ys
+
+## (#Cons x xs*)
+## (#Cons x (++-list xs* ys))))
+
+## (def (map-list f xs)
+## (case' xs
+## #Nil
+## #Nil
+
+## (#Cons x xs*)
+## (#Cons (f x) (map-list f xs*))))
#(
(def (untemplate-list untemplate tokens)
@@ -763,95 +733,95 @@ n
#(
(deftype (Session i o s)
- (All [s' r]
- (-> (-> i s' r)
- (-> o s [i s'])
- r))
-
- (All [s' s''] (-> (-> c s' [p s''])
- (-> [] s [c s']) (Session c p s)
- [p s'']))
- (All [] (-> (-> c s p)
- (-> p [])))
- (All [r] (-> c (Session r p s) p)))
+(All [s' r]
+(-> (-> i s' r)
+(-> o s [i s'])
+r))
+
+(All [s' s''] (-> (-> c s' [p s''])
+(-> [] s [c s']) (Session c p s)
+[p s'']))
+(All [] (-> (-> c s p)
+(-> p [])))
+(All [r] (-> c (Session r p s) p)))
(Session Int [] (Session Int (Session [] Int <END>)))
(bind (session' [])
- (lambda [x session']
- (bind (session' [])
- (lambda [y session'']
- (session'' (+ x y))))))
+(lambda [x session']
+(bind (session' [])
+(lambda [y session'']
+(session'' (+ x y))))))
(defstruct SessionMonad
- (Monad Session)
- (def (return v)
- (lambda [k session]
- (k v session)))
- (def (bind step m-value)
- (lambda [k session]
- (let [[v session'] (m-value [] session)]
- (k (step v) session')))))
+(Monad Session)
+(def (return v)
+(lambda [k session]
+(k v session)))
+(def (bind step m-value)
+(lambda [k session]
+(let [[v session'] (m-value [] session)]
+(k (step v) session')))))
## Not really "do"; but oh, well...
(deftype <NIL>
- (| #Nil))
+(| #Nil))
(deftype (HList h t)
- (| (#Cons h t)))
+(| (#Cons h t)))
(deftype (Session c p s)
- (All [r] (-> c (-> p s r) r)))
+(All [r] (-> c (-> p s r) r)))
(deftype (Session c p s)
- (-> (-> p s c) c))
+(-> (-> p s c) c))
(deftype (? r s)
- (Session r [] s))
+(Session r [] s))
(deftype (! w s)
- (Session [] w s))
+(Session [] w s))
(deftype #rec <END>
- (Session [] [] <END>))
+(Session [] [] <END>))
(def <<
- (lambda [k session]
- (k [] session)))
+(lambda [k session]
+(k [] session)))
(def (>> val)
- (lambda [k session]
- (session val k)))
+(lambda [k session]
+(session val k)))
(<$> << (>> 5))
(def (<$> consumer producer)
- (producer [] consumer))
+(producer [] consumer))
(HList Int (HList Int <NIL>))
(<.> (? Int) (? Int) (! Int) <END>)
(def fn-session
- (do [x <<
- y <<]
- (>> (+ x y))))
+(do [x <<
+y <<]
+(>> (+ x y))))
(<.> (! Int) (! Int) (? Int) <END>)
(def call-session
- (do [_ (>> 5)
- _ (>> 10)]
- <<))
+(do [_ (>> 5)
+_ (>> 10)]
+<<))
(<$> fn-session call-session)
(def <<
- (lambda [chan]
- (chan (lambda []))))
+(lambda [chan]
+(chan (lambda []))))
(def (>> value)
- (lambda [chan]
- (chan value)))
+(lambda [chan]
+(chan value)))
)#
## (defsig (Equal a)
@@ -875,7 +845,7 @@ n
## (defstruct (ListShow x)
## [&show (Show a)]
## (Show (List a))
-
+
## (def (show xs)
## (<> "(" (interpose ", " (map (:: &show show) xs)) ")")))
@@ -884,3 +854,56 @@ n
## {#show (lambda show [xs]
## (<> "(" (interpose ", " (map (:: &show show) xs)) ")"))})
## (-> (Show a) (Show (List a)))))
+
+## (deftype (Identity a) a)
+
+## (deftype (List a)
+## (| #Nil
+## (#Cons a (List a))))
+
+## (def (ListT m)
+## (All [a] (List (m a))))
+
+## (ListT Identity)
+
+## (defsig (Monad m)
+## (: return (All [a] (-> a (m a))))
+## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b)))))
+
+## (def Monad
+## (All [m]
+## (sig (: return (All [a] (-> a (m a))))
+## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b)))))))
+
+## (defstruct Monad<Identity> (Monad Identity)
+## (def (return x)
+## x)
+## (def (bind f x)
+## (f x)))
+
+## (: Monad<Identity> (Monad Identity))
+## (def Monad<Identity>
+## (struct
+## (def (return x)
+## x)
+## (def (bind f x)
+## (f x))))
+
+## (defstruct Monad<List> (All [m] (-> (Monad m)
+## (Monad (ListT m))))
+## (def (return x)
+## (list x))
+## (def (bind f xs)
+## (case xs
+## #Nil #Nil
+## (#Cons x xs') (#Cons (f x) (bind f xs')))))
+
+## (deftype #rec Type
+## ($data #Any
+## #Nothing
+## (#Data Text (List Type))
+## (#Lambda Type Type)
+## (#All (List [Text Type]) Text Text Type)
+## (#Exists (List [Text Type]) Text Type)
+## (#Lookup Text)
+## (#Var Int)))
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]