diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/host.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/host.jvm.lux | 185 |
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") |