- Moved all translation code under the JVM path (in preparation for porting the JS back-end).

1 files changed, 230 insertions, 0 deletions

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<Meta>])
+  (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<Meta>
+      [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 [<tag> <prep>]
+      [_ (<tag> value)]
+      (macro/wrap (|>> peekI
+                       ($i.unwrap #$.Long)
+                       ($i.long (|> value <prep>))
+                       $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 [<special> <method>]
+      (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.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
+                                          <method>
+                                          ($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 [<special> <flag>]
+      (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.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))
+                           <flag>
+                           ($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<Meta>
+      [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<Meta>
+      [@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<Meta>
+    [@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<Meta>
+    [@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<Meta>
+    [inputI (translate inputS)
+     exprI (translate exprS)]
+    (wrap (|>> inputI
+               ($i.ASTORE register)
+               exprI))))