From 581ccee156457b0f84696def59fc324c1cbbdaba Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Fri, 27 Dec 2019 00:51:00 -0400
Subject: Falling back to using the old method of JVM generation while I
 properly debug and optimize the new one.

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

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

diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux
new file mode 100644
index 000000000..fccbd14bf
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm.lux
@@ -0,0 +1,154 @@
+(.module:
+  [lux (#- Definition)
+   ["." host (#+ import: do-to object)]
+   [abstract
+    [monad (#+ do)]]
+   [control
+    pipe
+    ["." try (#+ Try)]
+    ["." exception (#+ exception:)]
+    ["." io (#+ IO io)]
+    [concurrency
+     ["." atom (#+ Atom atom)]]]
+   [data
+    [binary (#+ Binary)]
+    ["." product]
+    ["." text ("#@." hash)
+     ["%" format (#+ format)]]
+    [collection
+     ["." array]
+     ["." dictionary (#+ Dictionary)]]]
+   [target
+    [jvm
+     ["." loader (#+ Library)]
+     ["." type
+      ["." descriptor]]]]
+   [tool
+    [compiler
+     ["." name]]]]
+  [///
+   [host
+    ["." jvm (#+ Inst Definition Host State)
+     ["." def]
+     ["." inst]]]]
+  )
+
+(import: org/objectweb/asm/Label)
+
+(import: java/lang/reflect/Field
+  (get [#? Object] #try #? Object))
+
+(import: (java/lang/Class a)
+  (getField [String] #try Field))
+
+(import: java/lang/Object
+  (getClass [] (Class Object)))
+
+(import: java/lang/ClassLoader)
+
+(type: #export ByteCode Binary)
+
+(def: #export value-field Text "_value")
+(def: #export $Value (type.class "java.lang.Object" (list)))
+
+(exception: #export (cannot-load {class Text} {error Text})
+  (exception.report
+   ["Class" class]
+   ["Error" error]))
+
+(exception: #export (invalid-field {class Text} {field Text} {error Text})
+  (exception.report
+   ["Class" class]
+   ["Field" field]
+   ["Error" error]))
+
+(exception: #export (invalid-value {class Text})
+  (exception.report
+   ["Class" class]))
+
+(def: (class-value class-name class)
+  (-> Text (Class Object) (Try Any))
+  (case (Class::getField ..value-field class)
+    (#try.Success field)
+    (case (Field::get #.None field)
+      (#try.Success ?value)
+      (case ?value
+        (#.Some value)
+        (#try.Success value)
+        
+        #.None
+        (exception.throw invalid-value class-name))
+      
+      (#try.Failure error)
+      (exception.throw cannot-load [class-name error]))
+    
+    (#try.Failure error)
+    (exception.throw invalid-field [class-name ..value-field error])))
+
+(def: class-path-separator ".")
+
+(def: (evaluate! library loader eval-class valueI)
+  (-> Library ClassLoader Text Inst (Try [Any Definition]))
+  (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class)
+        bytecode (def.class #jvm.V1_6
+                            #jvm.Public jvm.noneC
+                            bytecode-name
+                            (list) $Value
+                            (list)
+                            (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF)
+                                            ..value-field ..$Value)
+                                 (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM)
+                                             "<clinit>"
+                                             (type.method [(list) type.void (list)])
+                                             (|>> valueI
+                                                  (inst.PUTSTATIC (type.class bytecode-name (list)) ..value-field ..$Value)
+                                                  inst.RETURN))))]
+    (io.run (do (try.with io.monad)
+              [_ (loader.store eval-class bytecode library)
+               class (loader.load eval-class loader)
+               value (:: io.monad wrap (class-value eval-class class))]
+              (wrap [value
+                     [eval-class bytecode]])))))
+
+(def: (execute! library loader temp-label [class-name class-bytecode])
+  (-> Library ClassLoader Text Definition (Try Any))
+  (io.run (do (try.with io.monad)
+            [existing-class? (|> (atom.read library)
+                                 (:: io.monad map (dictionary.contains? class-name))
+                                 (try.lift io.monad)
+                                 (: (IO (Try Bit))))
+             _ (if existing-class?
+                 (wrap [])
+                 (loader.store class-name class-bytecode library))]
+            (loader.load class-name loader))))
+
+(def: (define! library loader [module name] valueI)
+  (-> Library ClassLoader Name Inst (Try [Text Any Definition]))
+  (let [class-name (format (text.replace-all .module-separator class-path-separator module)
+                           class-path-separator (name.normalize name)
+                           "___" (%.nat (text@hash name)))]
+    (do try.monad
+      [[value definition] (evaluate! library loader class-name valueI)]
+      (wrap [class-name value definition]))))
+
+(def: #export host
+  (IO Host)
+  (io (let [library (loader.new-library [])
+            loader (loader.memory library)]
+        (: Host
+           (structure
+            (def: (evaluate! temp-label valueI)
+              (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))]
+                (:: try.monad map product.left
+                    (..evaluate! library loader eval-class valueI))))
+            
+            (def: execute!
+              (..execute! library loader))
+            
+            (def: define!
+              (..define! library loader)))))))
+
+(def: #export $Variant (type.array ..$Value))
+(def: #export $Tuple (type.array ..$Value))
+(def: #export $Function (type.class "LuxFunction" (list)))
+(def: #export $Runtime (type.class "LuxRuntime" (list)))
-- 
cgit v1.2.3