From 012f6bd41e527479dddbccbdab10daa78fd9a0fd Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 1 Nov 2017 00:51:45 -0400
Subject: - Re-organized code-generation, and re-named it "translation".

---
 new-luxc/source/luxc/lang/translation/case.jvm.lux | 225 +++++++++++++++++++++
 1 file changed, 225 insertions(+)
 create mode 100644 new-luxc/source/luxc/lang/translation/case.jvm.lux

(limited to 'new-luxc/source/luxc/lang/translation/case.jvm.lux')

diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux
new file mode 100644
index 000000000..a9ea4482a
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux
@@ -0,0 +1,225 @@
+(;module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data text/format)
+       [meta "meta/" Monad<Meta>])
+  (luxc ["_" base]
+        [";L" host]
+        (host ["$" jvm]
+              (jvm ["$t" type]
+                   ["$i" inst]))
+        (lang ["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: (generate-path' generate 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 meta;Monad<Meta>
+      [bodyI (generate bodyS)]
+      (wrap (|>. (pop-altI stack-depth)
+                 bodyI
+                 ($i;GOTO @end))))
+
+    (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))])
+    (meta/wrap popI)
+
+    (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))])
+    (meta/wrap (|>. peekI
+                    ($i;ASTORE register)
+                    popI))
+
+    [_ (#;Bool value)]
+    (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
+                 (|>. peekI
+                      ($i;unwrap #$;Boolean)
+                      (jumpI @else))))
+
+    (^template [<tag> <prep>]
+      [_ (<tag> value)]
+      (meta/wrap (|>. peekI
+                      ($i;unwrap #$;Long)
+                      ($i;long (|> value <prep>))
+                      $i;LCMP
+                      ($i;IFNE @else))))
+    ([#;Nat (:! Int)]
+     [#;Int (: Int)]
+     [#;Deg (:! Int)])
+
+    [_ (#;Frac value)]
+    (meta/wrap (|>. peekI
+                    ($i;unwrap #$;Double)
+                    ($i;double value)
+                    $i;DCMPL
+                    ($i;IFNE @else)))
+    
+    [_ (#;Text value)]
+    (meta/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)] subP))])
+      (do meta;Monad<Meta>
+        [subI (generate-path' generate stack-depth @else @end subP)]
+        (wrap (case idx
+                +0
+                (|>. peekI
+                     ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
+                     ($i;int 0)
+                     $i;AALOAD
+                     pushI
+                     subI)
+                
+                _
+                (|>. 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
+                     subI)))))
+    (["lux case tuple left" "pm_left"]
+     ["lux case tuple right" "pm_right"])
+
+    (^template [<special> <flag>]
+      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))])
+      (do meta;Monad<Meta>
+        [subI (generate-path' generate stack-depth @else @end subP)]
+        (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
+                       subI)))))
+    (["lux case variant left" $i;NULL]
+     ["lux case variant right" ($i;string "")])
+    
+    (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))])
+    (do meta;Monad<Meta>
+      [leftI (generate-path' generate stack-depth @else @end leftP)
+       rightI (generate-path' generate stack-depth @else @end rightP)]
+      (wrap (|>. leftI
+                 rightI)))
+
+    (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))])
+    (do meta;Monad<Meta>
+      [@alt-else $i;make-label
+       leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP)
+       rightI (generate-path' generate stack-depth @else @end rightP)]
+      (wrap (|>. $i;DUP
+                 leftI
+                 ($i;label @alt-else)
+                 $i;POP
+                 rightI)))
+
+    _
+    (_;throw Unrecognized-Path (%code path))))
+
+(def: (generate-path generate path @end)
+  (-> (-> ls;Synthesis (Meta $;Inst))
+      ls;Path $;Label (Meta $;Inst))
+  (do meta;Monad<Meta>
+    [@else $i;make-label
+     pathI (generate-path' generate +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 (generate-case generate valueS path)
+  (-> (-> ls;Synthesis (Meta $;Inst))
+      ls;Synthesis ls;Path (Meta $;Inst))
+  (do meta;Monad<Meta>
+    [@end $i;make-label
+     valueI (generate valueS)
+     pathI (generate-path generate path @end)]
+    (wrap (|>. valueI
+               $i;NULL
+               $i;SWAP
+               pushI
+               pathI
+               ($i;label @end)))))
+
+(def: #export (generate-let generate register inputS exprS)
+  (-> (-> ls;Synthesis (Meta $;Inst))
+      Nat ls;Synthesis ls;Synthesis (Meta $;Inst))
+  (do meta;Monad<Meta>
+    [inputI (generate inputS)
+     exprI (generate exprS)]
+    (wrap (|>. inputI
+               ($i;ASTORE register)
+               exprI))))
-- 
cgit v1.2.3