From 296d087530cb142efec1dea159770346bb43c3c0 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 15 Nov 2017 19:51:33 -0400
Subject: - Heavy refactoring.
---
new-luxc/source/luxc/host.jvm.lux | 185 --------------------------------------
1 file changed, 185 deletions(-)
delete mode 100644 new-luxc/source/luxc/host.jvm.lux
(limited to 'new-luxc/source/luxc/host.jvm.lux')
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]
- [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)))]
- {#commonT;loader (memory-class-loader store)
- #commonT;store store
- #commonT;artifacts (dict;new text;Hash)
- #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")
--
cgit v1.2.3