- Heavy refactoring.

1 files changed, 185 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux
new file mode 100644
index 000000000..ae1d29387
--- /dev/null
+++ b/new-luxc/source/luxc/lang/host.jvm.lux
@@ -0,0 +1,185 @@
+(;module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:]
+                pipe)
+       (concurrency ["A" atom])
+       (data ["e" error]
+             [text]
+             text/format
+             (coll [dict]
+                   [array]))
+       [meta #+ Monad<Meta>]
+       [host #+ do-to object]
+       [io])
+  (luxc ["&" lang]
+        (lang [";L" variable #+ Register]
+              (translation [";T" common]))))
+
+(host;import org.objectweb.asm.Label)
+
+(host;import java.lang.reflect.AccessibleObject
+  (setAccessible [boolean] void))
+
+(host;import java.lang.reflect.Method
+  (invoke [Object (Array Object)] #try Object))
+
+(host;import (java.lang.Class a)
+  (getDeclaredMethod [String (Array (Class Object))] #try Method))
+
+(host;import java.lang.Object
+  (getClass [] (Class Object)))
+
+(host;import java.lang.Integer
+  (#static TYPE (Class Integer)))
+
+(host;import java.lang.ClassLoader)
+
+(def: ClassLoader::defineClass
+  Method
+  (case (Class.getDeclaredMethod ["defineClass"
+                                  (|> (host;array (Class Object) +4)
+                                      (host;array-write +0 (:! (Class Object) (host;class-for String)))
+                                      (host;array-write +1 (Object.getClass [] (host;array byte +0)))
+                                      (host;array-write +2 (:! (Class Object) Integer.TYPE))
+                                      (host;array-write +3 (:! (Class Object) Integer.TYPE)))]
+                                 (host;class-for java.lang.ClassLoader))
+    (#e;Success method)
+    (do-to method
+      (AccessibleObject.setAccessible [true]))
+
+    (#e;Error error)
+    (error! error)))
+
+(def: (define-class class-name byte-code loader)
+  (-> Text commonT;Bytecode ClassLoader (e;Error Object))
+  (Method.invoke [loader
+                  (array;from-list (list (:! Object class-name)
+                                         (:! Object byte-code)
+                                         (:! Object (host;l2i 0))
+                                         (:! Object (host;l2i (nat-to-int (host;array-length byte-code))))))]
+                 ClassLoader::defineClass))
+
+(def: (fetch-byte-code class-name store)
+  (-> Text commonT;Class-Store (Maybe commonT;Bytecode))
+  (|> store A;get io;run (dict;get class-name)))
+
+(def: (memory-class-loader store)
+  (-> commonT;Class-Store ClassLoader)
+  (object ClassLoader []
+    []
+    (ClassLoader (findClass [class-name String]) Class
+                 (case (fetch-byte-code class-name store)
+                   (#;Some bytecode)
+                   (case (define-class class-name bytecode (:! ClassLoader _jvm_this))
+                     (#e;Success class)
+                     (:!! class)
+
+                     (#e;Error error)
+                     (error! (format "Class definition error: " class-name "\n"
+                                     error)))
+
+                   #;None
+                   (error! (format "Class not found: " class-name))))))
+
+(def: #export init-host
+  (io;IO commonT;Host)
+  (io;io (let [store (: commonT;Class-Store
+                        (A;atom (dict;new text;Hash<Text>)))]
+           {#commonT;loader (memory-class-loader store)
+            #commonT;store store
+            #commonT;artifacts (dict;new text;Hash<Text>)
+            #commonT;context ["" +0]
+            #commonT;anchor #;None})))
+
+(def: #export (with-anchor anchor expr)
+  (All [a] (-> [Label Register] (Meta a) (Meta a)))
+  (;function [compiler]
+    (let [old (:! commonT;Host (get@ #;host compiler))]
+      (case (expr (set@ #;host
+                        (:! Void (set@ #commonT;anchor (#;Some anchor) old))
+                        compiler))
+        (#e;Success [compiler' output])
+        (#e;Success [(update@ #;host
+                              (|>. (:! commonT;Host)
+                                   (set@ #commonT;anchor (get@ #commonT;anchor old))
+                                   (:! Void))
+                              compiler')
+                     output])
+
+        (#e;Error error)
+        (#e;Error error)))))
+
+(exception: #export No-Anchor)
+
+(def: #export anchor
+  (Meta [Label Register])
+  (;function [compiler]
+    (case (|> compiler (get@ #;host) (:! commonT;Host) (get@ #commonT;anchor))
+      (#;Some anchor)
+      (#e;Success [compiler
+                   anchor])
+
+      #;None
+      ((&;throw No-Anchor "") compiler))))
+
+(def: #export (with-context name expr)
+  (All [a] (-> Text (Meta a) (Meta a)))
+  (;function [compiler]
+    (let [old (:! commonT;Host (get@ #;host compiler))]
+      (case (expr (set@ #;host
+                        (:! Void (set@ #commonT;context [(&;normalize-name name) +0] old))
+                        compiler))
+        (#e;Success [compiler' output])
+        (#e;Success [(update@ #;host
+                              (|>. (:! commonT;Host)
+                                   (set@ #commonT;context (get@ #commonT;context old))
+                                   (:! Void))
+                              compiler')
+                     output])
+
+        (#e;Error error)
+        (#e;Error error)))))
+
+(def: #export (with-sub-context expr)
+  (All [a] (-> (Meta a) (Meta [Text a])))
+  (;function [compiler]
+    (let [old (:! commonT;Host (get@ #;host compiler))
+          [old-name old-sub] (get@ #commonT;context old)
+          new-name (format old-name "$" (%i (nat-to-int old-sub)))]
+      (case (expr (set@ #;host
+                        (:! Void (set@ #commonT;context [new-name +0] old))
+                        compiler))
+        (#e;Success [compiler' output])
+        (#e;Success [(update@ #;host
+                              (|>. (:! commonT;Host)
+                                   (set@ #commonT;context [old-name (n.inc old-sub)])
+                                   (:! Void))
+                              compiler')
+                     [new-name output]])
+
+        (#e;Error error)
+        (#e;Error error)))))
+
+(def: #export context
+  (Meta Text)
+  (;function [compiler]
+    (#e;Success [compiler
+                 (|> (get@ #;host compiler)
+                     (:! commonT;Host)
+                     (get@ #commonT;context)
+                     (let> [name sub]
+                           name))])))
+
+(def: #export class-loader
+  (Meta ClassLoader)
+  (function [compiler]
+    (#e;Success [compiler
+                 (|> compiler
+                     (get@ #;host)
+                     (:! commonT;Host)
+                     (get@ #commonT;loader))])))
+
+(def: #export runtime-class Text "LuxRuntime")
+(def: #export function-class Text "LuxFunction")
+(def: #export unit Text "\u0000")