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

1 files changed, 136 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux
new file mode 100644
index 000000000..a4eb5b93b
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux
@@ -0,0 +1,136 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       [io]
+       (concurrency [atom #+ Atom atom])
+       (data ["e" error #+ Error]
+             [text "text/" Hash<Text>]
+             text/format
+             (coll [dict #+ Dict]))
+       [macro]
+       [host]
+       (world [blob #+ Blob]
+              [file #+ File]))
+  (luxc [lang]
+        (lang [".L" variable #+ Register]
+              (host ["$" jvm]
+                    (jvm ["$t" type]
+                         ["$d" def]
+                         ["$i" inst])))))
+
+(host.import org/objectweb/asm/Opcodes
+  (#static V1_6 int))
+
+(host.import org/objectweb/asm/Label)
+
+(host.import java/lang/Object)
+
+(host.import java/lang/reflect/Field
+  (get [#? Object] #try #? Object))
+
+(host.import (java/lang/Class c)
+  (getField [String] #try Field))
+
+(host.import java/lang/ClassLoader
+  (loadClass [String] (Class Object)))
+
+(type: #export Bytecode Blob)
+
+(type: #export Class-Store (Atom (Dict Text Bytecode)))
+
+(type: #export Artifacts (Dict File Blob))
+
+(type: #export Host
+  {#loader ClassLoader
+   #store Class-Store
+   #artifacts Artifacts
+   #context [Text Nat]
+   #anchor (Maybe [Label Register])})
+
+(exception: #export Unknown-Class)
+(exception: #export Class-Already-Stored)
+(exception: #export No-Function-Being-Compiled)
+(exception: #export Cannot-Overwrite-Artifact)
+(exception: #export Cannot-Load-Definition)
+(exception: #export Invalid-Definition-Value)
+
+(def: #export (with-artifacts action)
+  (All [a] (-> (Meta a) (Meta [Artifacts a])))
+  (function [compiler]
+    (case (action (update@ #.host
+                           (|>> (:! Host)
+                                (set@ #artifacts (dict.new text.Hash<Text>))
+                                (:! Void))
+                           compiler))
+      (#e.Success [compiler' output])
+      (#e.Success [(update@ #.host
+                            (|>> (:! Host)
+                                 (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts)))
+                                 (:! Void))
+                            compiler')
+                   [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts))
+                    output]])
+      
+      (#e.Error error)
+      (#e.Error error))))
+
+(def: #export (record-artifact name content)
+  (-> Text Blob (Meta Unit))
+  (function [compiler]
+    (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name))
+      (ex.throw Cannot-Overwrite-Artifact name)
+      (#e.Success [(update@ #.host
+                            (|>> (:! Host)
+                                 (update@ #artifacts (dict.put name content))
+                                 (:! Void))
+                            compiler)
+                   []]))))
+
+(def: #export (store-class name byte-code)
+  (-> Text Bytecode (Meta Unit))
+  (function [compiler]
+    (let [store (|> (get@ #.host compiler)
+                    (:! Host)
+                    (get@ #store))]
+      (if (dict.contains? name (|> store atom.read io.run))
+        (ex.throw Class-Already-Stored name)
+        (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))])
+        ))))
+
+(def: #export (load-class name)
+  (-> Text (Meta (Class Object)))
+  (function [compiler]
+    (let [host (:! Host (get@ #.host compiler))
+          store (|> host (get@ #store) atom.read io.run)]
+      (if (dict.contains? name store)
+        (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))])
+        (ex.throw Unknown-Class name)))))
+
+(def: #export value-field Text "_value")
+(def: #export $Object $.Type ($t.class "java.lang.Object" (list)))
+
+(def: #export (load-definition compiler)
+  (-> Compiler
+      (-> Ident Blob (Error Top)))
+  (function [(^@ def-ident [def-module def-name]) def-bytecode]
+    (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name)))
+          class-name (format (text.replace-all "/" "." def-module) "." normal-name)]
+      (<| (macro.run compiler)
+          (do macro.Monad<Meta>
+            [_ (..store-class class-name def-bytecode)
+             class (..load-class class-name)]
+            (case (do e.Monad<Error>
+                    [field (Class::getField [..value-field] class)]
+                    (Field::get [#.None] field))
+              (#e.Success (#.Some def-value))
+              (wrap def-value)
+
+              (#e.Success #.None)
+              (lang.throw Invalid-Definition-Value (%ident def-ident))
+              
+              (#e.Error error)
+              (lang.throw Cannot-Load-Definition
+                          (format "Definition: " (%ident def-ident) "\n"
+                                  "Error:\n"
+                                  error))))))))