diff options
| -rw-r--r-- | source/lux.lux | 469 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 24 | ||||
| -rw-r--r-- | src/lux/analyser/lambda.clj | 4 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 1 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 706 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 15 |
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] |