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

1 files changed, 159 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux
new file mode 100644
index 000000000..1b828535f
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux
@@ -0,0 +1,159 @@
+(.module:
+  lux
+  (lux (control monad
+                ["ex" exception #+ exception:])
+       (data ["e" error]
+             [maybe]
+             [text "text/" Monoid<Text> Hash<Text>]
+             text/format
+             (coll [list "list/" Functor<List> Fold<List>]))
+       [macro]
+       [host])
+  (luxc ["&" lang]
+        ["&." io]
+        (lang (host ["$" jvm]
+                    (jvm ["$t" type]
+                         ["$d" def]
+                         ["$i" inst]))
+              ["&." scope]
+              ["&." module]
+              [".L" host]))
+  (// [".T" eval]
+      [".T" common]
+      [".T" runtime]))
+
+(exception: #export Invalid-Definition-Value)
+(exception: #export Cannot-Evaluate-Definition)
+
+(host.import java/lang/reflect/Field
+  (get [#? Object] #try #? Object))
+
+(host.import (java/lang/Class c)
+  (getField [String] #try Field))
+
+(def: #export (translate-def def-name valueT valueI metaI metaV)
+  (-> Text Type $.Inst $.Inst Code (Meta Unit))
+  (do macro.Monad<Meta>
+    [current-module macro.current-module-name
+     #let [def-ident [current-module def-name]]]
+    (case (macro.get-symbol-ann (ident-for #.alias) metaV)
+      (#.Some real-def)
+      (do @
+        [[realT realA realV] (macro.find-def real-def)
+         _ (&module.define def-ident [realT metaV realV])]
+        (wrap []))
+
+      _
+      (do @
+        [#let [normal-name (format (&.normalize-name def-name) (%n (text/hash def-name)))
+               bytecode-name (format current-module "/" normal-name)
+               class-name (format (text.replace-all "/" "." current-module) "." normal-name)
+               bytecode ($d.class #$.V1_6
+                                  #$.Public $.finalC
+                                  bytecode-name
+                                  (list) ["java.lang.Object" (list)]
+                                  (list)
+                                  (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) commonT.value-field commonT.$Object)
+                                       ($d.method #$.Public $.staticM "<clinit>" ($t.method (list) #.None (list))
+                                                  (|>> valueI
+                                                       ($i.PUTSTATIC bytecode-name commonT.value-field commonT.$Object)
+                                                       $i.RETURN))))]
+         _ (commonT.store-class class-name bytecode)
+         class (commonT.load-class class-name)
+         valueV (: (Meta Top)
+                   (case (do e.Monad<Error>
+                           [field (Class::getField [commonT.value-field] class)]
+                           (Field::get [#.None] field))
+                     (#e.Success #.None)
+                     (&.throw Invalid-Definition-Value (%ident def-ident))
+                     
+                     (#e.Success (#.Some valueV))
+                     (wrap valueV)
+                     
+                     (#e.Error error)
+                     (&.throw Cannot-Evaluate-Definition
+                              (format "Definition: " (%ident def-ident) "\n"
+                                      "Error:\n"
+                                      error))))
+         _ (&module.define def-ident [valueT metaV valueV])
+         _ (if (macro.type? metaV)
+             (case (macro.declared-tags metaV)
+               #.Nil
+               (wrap [])
+
+               tags
+               (&module.declare-tags tags (macro.export? metaV) (:! Type valueV)))
+             (wrap []))
+         #let [_ (log! (format "DEF " (%ident def-ident)))]]
+        (commonT.record-artifact (format bytecode-name ".class") bytecode)))))
+
+(def: #export (translate-program programI)
+  (-> $.Inst (Meta Unit))
+  (let [nilI runtimeT.noneI
+        num-inputsI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH)
+        decI (|>> ($i.int 1) $i.ISUB)
+        headI (|>> $i.DUP
+                   ($i.ALOAD +0)
+                   $i.SWAP
+                   $i.AALOAD
+                   $i.SWAP
+                   $i.DUP_X2
+                   $i.POP)
+        pairI (|>> ($i.int 2)
+                   ($i.ANEWARRAY "java.lang.Object")
+                   $i.DUP_X1
+                   $i.SWAP
+                   ($i.int 0)
+                   $i.SWAP
+                   $i.AASTORE
+                   $i.DUP_X1
+                   $i.SWAP
+                   ($i.int 1)
+                   $i.SWAP
+                   $i.AASTORE)
+        consI (|>> ($i.int 1)
+                   ($i.string "")
+                   $i.DUP2_X1
+                   $i.POP2
+                   runtimeT.variantI)
+        prepare-input-listI (<| $i.with-label (function [@loop])
+                                $i.with-label (function [@end])
+                                (|>> nilI
+                                     num-inputsI
+                                     ($i.label @loop)
+                                     decI
+                                     $i.DUP
+                                     ($i.IFLT @end)
+                                     headI
+                                     pairI
+                                     consI
+                                     $i.SWAP
+                                     ($i.GOTO @loop)
+                                     ($i.label @end)
+                                     $i.POP
+                                     ($i.ASTORE +0)))
+        run-ioI (|>> ($i.CHECKCAST hostL.function-class)
+                     $i.NULL
+                     ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature +1) false))
+        main-type ($t.method (list ($t.array +1 ($t.class "java.lang.String" (list))))
+                             #.None
+                             (list))]
+    (do macro.Monad<Meta>
+      [current-module macro.current-module-name
+       #let [normal-name "_"
+             bytecode-name (format current-module "/" normal-name)
+             class-name (text.replace-all "/" "." bytecode-name)
+             bytecode ($d.class #$.V1_6
+                                #$.Public $.finalC
+                                bytecode-name
+                                (list) ["java.lang.Object" (list)]
+                                (list)
+                                (|>> ($d.method #$.Public $.staticM "main" main-type
+                                                (|>> prepare-input-listI
+                                                     programI
+                                                     run-ioI
+                                                     $i.POP
+                                                     $i.RETURN))))]
+       #let [_ (log! (format "PROGRAM " current-module))]
+       _ (commonT.store-class class-name bytecode)]
+      (commonT.record-artifact (format bytecode-name ".class") bytecode))))