diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/host.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/host.jvm.lux | 188 |
1 files changed, 0 insertions, 188 deletions
diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux deleted file mode 100644 index b207fdad7..000000000 --- a/new-luxc/source/luxc/lang/host.jvm.lux +++ /dev/null @@ -1,188 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - pipe) - (concurrency [atom #+ Atom atom]) - (data ["e" error] - [text] - text/format - (coll (dictionary ["dict" unordered]) - [array])) - [macro] - [host #+ do-to object] - [io] - ["//" lang] - (lang ["//." reference #+ Register])) - (luxc [lang] - (lang (translation (jvm [".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 (:coerce (Class Object) (host.class-for String))) - (host.array-write +1 (Object::getClass [] (host.array byte +0))) - (host.array-write +2 (:coerce (Class Object) Integer::TYPE)) - (host.array-write +3 (:coerce (Class Object) Integer::TYPE)))] - (host.class-for java/lang/ClassLoader)) - (#e.Success method) - (do-to method - (AccessibleObject::setAccessible [#1])) - - (#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 (:coerce Object class-name) - (:coerce Object byte-code) - (:coerce Object (host.long-to-int 0)) - (:coerce Object (host.long-to-int (.int (host.array-length byte-code))))))] - ClassLoader::defineClass)) - -(def: (fetch-byte-code class-name store) - (-> Text commonT.Class-Store (Maybe commonT.Bytecode)) - (|> store atom.read 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 (:coerce ClassLoader _jvm_this)) - (#e.Success class) - (:assume 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 - (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 (:coerce commonT.Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #commonT.anchor (#.Some anchor) old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce commonT.Host) - (set@ #commonT.anchor (get@ #commonT.anchor old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(exception: #export (No-Anchor {message Text}) - message) - -(def: #export anchor - (Meta [Label Register]) - (.function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce 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 (:coerce commonT.Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #commonT.context [(lang.normalize-name name) +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce commonT.Host) - (set@ #commonT.context (get@ #commonT.context old)) - (:coerce Nothing)) - 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 (:coerce commonT.Host (get@ #.host compiler)) - [old-name old-sub] (get@ #commonT.context old) - new-name (format old-name "$" (%i (.int old-sub)))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #commonT.context [new-name +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce commonT.Host) - (set@ #commonT.context [old-name (inc old-sub)]) - (:coerce Nothing)) - compiler') - [new-name output]]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export context - (Meta Text) - (.function (_ compiler) - (#e.Success [compiler - (|> (get@ #.host compiler) - (:coerce commonT.Host) - (get@ #commonT.context) - (let> [name sub] - name))]))) - -(def: #export class-loader - (Meta ClassLoader) - (function (_ compiler) - (#e.Success [compiler - (|> compiler - (get@ #.host) - (:coerce commonT.Host) - (get@ #commonT.loader))]))) - -(def: #export runtime-class Text "LuxRuntime") -(def: #export function-class Text "LuxFunction") -(def: #export runnable-class Text "LuxRunnable") -(def: #export unit Text "") |