From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 8 Jan 2018 21:40:06 -0400
Subject: - Moved all translation code under the JVM path (in preparation for
porting the JS back-end).
---
.../source/luxc/lang/translation/jvm/case.jvm.lux | 230 +++++++++++++++++++++
1 file changed, 230 insertions(+)
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
(limited to 'new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux')
diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
new file mode 100644
index 000000000..b693f50b8
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
@@ -0,0 +1,230 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data text/format)
+ [macro "macro/" Monad])
+ (luxc ["_" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$i" inst]))
+ ["ls" synthesis]))
+ [//runtime])
+
+(def: $Object $.Type ($t.class "java.lang.Object" (list)))
+
+(def: (pop-altI stack-depth)
+ (-> Nat $.Inst)
+ (case stack-depth
+ +0 id
+ +1 $i.POP
+ +2 $i.POP2
+ _ ## (n/> +2)
+ (|>> $i.POP2
+ (pop-altI (n/- +2 stack-depth)))))
+
+(def: peekI
+ $.Inst
+ (|>> $i.DUP
+ ($i.INVOKESTATIC hostL.runtime-class
+ "pm_peek"
+ ($t.method (list //runtime.$Stack)
+ (#.Some $Object)
+ (list))
+ false)))
+
+(def: popI
+ $.Inst
+ (|>> ($i.INVOKESTATIC hostL.runtime-class
+ "pm_pop"
+ ($t.method (list //runtime.$Stack)
+ (#.Some //runtime.$Stack)
+ (list))
+ false)))
+
+(def: pushI
+ $.Inst
+ (|>> ($i.INVOKESTATIC hostL.runtime-class
+ "pm_push"
+ ($t.method (list //runtime.$Stack $Object)
+ (#.Some //runtime.$Stack)
+ (list))
+ false)))
+
+(exception: #export Unrecognized-Path)
+
+(def: (translate-path' translate stack-depth @else @end path)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ Nat $.Label $.Label ls.Path (Meta $.Inst))
+ (case path
+ (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
+ (do macro.Monad
+ [bodyI (translate bodyS)]
+ (wrap (|>> (pop-altI stack-depth)
+ bodyI
+ ($i.GOTO @end))))
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))])
+ (macro/wrap popI)
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))])
+ (macro/wrap (|>> peekI
+ ($i.ASTORE register)))
+
+ [_ (#.Bool value)]
+ (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)]
+ (|>> peekI
+ ($i.unwrap #$.Boolean)
+ (jumpI @else))))
+
+ (^template [ ]
+ [_ ( value)]
+ (macro/wrap (|>> peekI
+ ($i.unwrap #$.Long)
+ ($i.long (|> value ))
+ $i.LCMP
+ ($i.IFNE @else))))
+ ([#.Nat (:! Int)]
+ [#.Int (: Int)]
+ [#.Deg (:! Int)])
+
+ [_ (#.Frac value)]
+ (macro/wrap (|>> peekI
+ ($i.unwrap #$.Double)
+ ($i.double value)
+ $i.DCMPL
+ ($i.IFNE @else)))
+
+ [_ (#.Text value)]
+ (macro/wrap (|>> peekI
+ ($i.string value)
+ ($i.INVOKEVIRTUAL "java.lang.Object"
+ "equals"
+ ($t.method (list $Object)
+ (#.Some $t.boolean)
+ (list))
+ false)
+ ($i.IFEQ @else)))
+
+ (^template [ ]
+ (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
+ (macro/wrap (case idx
+ +0
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
+ ($i.int 0)
+ $i.AALOAD
+ pushI)
+
+ _
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
+ ($i.int (nat-to-int idx))
+ ($i.INVOKESTATIC hostL.runtime-class
+
+ ($t.method (list //runtime.$Tuple $t.int)
+ (#.Some $Object)
+ (list))
+ false)
+ pushI))))
+ (["lux case tuple left" "pm_left"]
+ ["lux case tuple right" "pm_right"])
+
+ (^template [ ]
+ (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
+ (macro/wrap (<| $i.with-label (function [@success])
+ $i.with-label (function [@fail])
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor //runtime.$Variant))
+ ($i.int (nat-to-int idx))
+
+ ($i.INVOKESTATIC hostL.runtime-class "pm_variant"
+ ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag)
+ (#.Some //runtime.$Datum)
+ (list))
+ false)
+ $i.DUP
+ ($i.IFNULL @fail)
+ ($i.GOTO @success)
+ ($i.label @fail)
+ $i.POP
+ ($i.GOTO @else)
+ ($i.label @success)
+ pushI))))
+ (["lux case variant left" $i.NULL]
+ ["lux case variant right" ($i.string "")])
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))])
+ (do macro.Monad
+ [leftI (translate-path' translate stack-depth @else @end leftP)
+ rightI (translate-path' translate stack-depth @else @end rightP)]
+ (wrap (|>> leftI
+ rightI)))
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))])
+ (do macro.Monad
+ [@alt-else $i.make-label
+ leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP)
+ rightI (translate-path' translate stack-depth @else @end rightP)]
+ (wrap (|>> $i.DUP
+ leftI
+ ($i.label @alt-else)
+ $i.POP
+ rightI)))
+
+ _
+ (_.throw Unrecognized-Path (%code path))))
+
+(def: (translate-path translate path @end)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ ls.Path $.Label (Meta $.Inst))
+ (do macro.Monad
+ [@else $i.make-label
+ pathI (translate-path' translate +1 @else @end path)]
+ (wrap (|>> pathI
+ ($i.label @else)
+ $i.POP
+ ($i.INVOKESTATIC hostL.runtime-class
+ "pm_fail"
+ ($t.method (list) #.None (list))
+ false)
+ $i.NULL
+ ($i.GOTO @end)))))
+
+(def: #export (translate-if testI thenI elseI)
+ (-> $.Inst $.Inst $.Inst $.Inst)
+ (<| $i.with-label (function [@else])
+ $i.with-label (function [@end])
+ (|>> testI
+ ($i.unwrap #$.Boolean)
+ ($i.IFEQ @else)
+ thenI
+ ($i.GOTO @end)
+ ($i.label @else)
+ elseI
+ ($i.label @end))))
+
+(def: #export (translate-case translate valueS path)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ ls.Synthesis ls.Path (Meta $.Inst))
+ (do macro.Monad
+ [@end $i.make-label
+ valueI (translate valueS)
+ pathI (translate-path translate path @end)]
+ (wrap (|>> valueI
+ $i.NULL
+ $i.SWAP
+ pushI
+ pathI
+ ($i.label @end)))))
+
+(def: #export (translate-let translate register inputS exprS)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ Nat ls.Synthesis ls.Synthesis (Meta $.Inst))
+ (do macro.Monad
+ [inputI (translate inputS)
+ exprI (translate exprS)]
+ (wrap (|>> inputI
+ ($i.ASTORE register)
+ exprI))))
--
cgit v1.2.3