diff options
author | Eduardo Julian | 2017-11-15 19:51:33 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-11-15 19:51:33 -0400 |
commit | 296d087530cb142efec1dea159770346bb43c3c0 (patch) | |
tree | bde43594e5df48af539a0fda3e13cbf6aa36b557 /new-luxc/source/luxc/host.jvm.lux | |
parent | c4e928e5805054aa12da40baaeccbb9c522b52d0 (diff) |
- Heavy refactoring.
Diffstat (limited to 'new-luxc/source/luxc/host.jvm.lux')
-rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 185 |
1 files changed, 0 insertions, 185 deletions
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux deleted file mode 100644 index e8dc4e17a..000000000 --- a/new-luxc/source/luxc/host.jvm.lux +++ /dev/null @@ -1,185 +0,0 @@ -(;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 ["&" base] - (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") |