aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/host.jvm.lux
blob: d5b4e89b093acc1d9f711be849980278aa9e9b32 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
(;module:
  lux
  (lux (control monad)
       (concurrency ["A" atom])
       (data ["R" result]
             [text]
             text/format
             (coll ["d" dict]
                   [array #+ Array]))
       [macro #+ Monad<Lux>]
       host
       [io])
  (luxc ["&" base]
        (generator ["&&;" common])
        ))

(jvm-import java.lang.reflect.AccessibleObject
  (setAccessible [boolean] void))

(jvm-import java.lang.reflect.Method
  (invoke [Object (Array Object)] #try Object))

(jvm-import (java.lang.Class a)
  (getDeclaredMethod [String (Array (Class Object))] #try Method))

(jvm-import java.lang.Object
  (getClass [] (Class Object)))

(jvm-import java.lang.Integer
  (#static TYPE (Class Integer)))

(jvm-import java.lang.ClassLoader)

(def: ClassLoader::defineClass
  Method
  (case (Class.getDeclaredMethod ["defineClass"
                                  (|> (array (Class Object) +4)
                                      (array-store +0 (:! (Class Object) (class-for String)))
                                      (array-store +1 (Object.getClass [] (array byte +0)))
                                      (array-store +2 (:! (Class Object) Integer.TYPE))
                                      (array-store +3 (:! (Class Object) Integer.TYPE)))]
                                 (class-for java.lang.ClassLoader))
    (#R;Success method)
    (do-to method
      (AccessibleObject.setAccessible [true]))

    (#R;Error error)
    (error! error)))

(def: (define-class class-name byte-code loader)
  (-> Text &&common;Bytecode ClassLoader (R;Result Object))
  (Method.invoke [loader
                  (array;from-list (list (:! Object class-name)
                                         (:! Object byte-code)
                                         (:! Object (l2i 0))
                                         (:! Object (l2i (nat-to-int (array-length byte-code))))))]
                 ClassLoader::defineClass))

(def: (fetch-byte-code class-name store)
  (-> Text &&common;Class-Store (Maybe &&common;Bytecode))
  (|> store A;get io;run (d;get class-name)))

(def: (memory-class-loader store)
  (-> &&common;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))
                     (#R;Success class)
                     (:!! class)

                     (#R;Error error)
                     (error! (format "Class definiton error: " class-name "\n"
                                     error)))

                   #;None
                   (error! (format "Class not found: " class-name))))))

(def: #export (init-host _)
  (-> Top &&common;Host)
  (let [store (: &&common;Class-Store
                 (A;atom (d;new text;Hash<Text>)))]
    {#&&common;loader (memory-class-loader store)
     #&&common;store store}))