(;module:
lux
(lux (control [monad #+ do])
(concurrency ["A" atom])
(data ["e" error]
[text]
text/format
(coll [dict]
[array]))
[meta #+ Monad]
[host #+ do-to object]
[io])
(luxc ["&" base]
(lang (translation [";T" common]))))
(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)))]
{#commonT;loader (memory-class-loader store)
#commonT;store store
#commonT;function-class #;None
#commonT;artifacts (dict;new text;Hash)})))
(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")