blob: 1d8da2893591989dd0e31cde53b063b5bf38ddab (
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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
[io]
(concurrency [atom #+ Atom atom])
(data ["e" error #+ Error]
[text "text/" Hash<Text>]
text/format
(coll (dictionary ["dict" unordered #+ Dict])))
[macro]
[host]
(world [blob #+ Blob]
[file #+ File]))
(luxc [lang]
(lang [".L" variable #+ Register]
(host ["$" jvm]
(jvm ["$t" type]
["$d" def]
["$i" inst])))))
(host.import org/objectweb/asm/Opcodes
(#static V1_6 int))
(host.import org/objectweb/asm/Label)
(host.import java/lang/Object)
(host.import java/lang/reflect/Field
(get [#? Object] #try #? Object))
(host.import (java/lang/Class c)
(getField [String] #try Field))
(host.import java/lang/ClassLoader
(loadClass [String] (Class Object)))
(type: #export Bytecode Blob)
(type: #export Class-Store (Atom (Dict Text Bytecode)))
(type: #export Artifacts (Dict File Blob))
(type: #export Host
{#context [Text Nat]
#anchor (Maybe [Label Register])
#loader ClassLoader
#store Class-Store
#artifacts Artifacts})
(do-template [<name>]
[(exception: #export (<name> {message Text})
message)]
[Unknown-Class]
[Class-Already-Stored]
[No-Function-Being-Compiled]
[Cannot-Overwrite-Artifact]
[Cannot-Load-Definition]
[Invalid-Definition-Value]
)
(def: #export (with-artifacts action)
(All [a] (-> (Meta a) (Meta [Artifacts a])))
(function (_ compiler)
(case (action (update@ #.host
(|>> (:! Host)
(set@ #artifacts (dict.new text.Hash<Text>))
(:! Nothing))
compiler))
(#e.Success [compiler' output])
(#e.Success [(update@ #.host
(|>> (:! Host)
(set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts)))
(:! Nothing))
compiler')
[(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts))
output]])
(#e.Error error)
(#e.Error error))))
(def: #export (record-artifact name content)
(-> Text Blob (Meta Any))
(function (_ compiler)
(if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name))
(ex.throw Cannot-Overwrite-Artifact name)
(#e.Success [(update@ #.host
(|>> (:! Host)
(update@ #artifacts (dict.put name content))
(:! Nothing))
compiler)
[]]))))
(def: #export (store-class name byte-code)
(-> Text Bytecode (Meta Any))
(function (_ compiler)
(let [store (|> (get@ #.host compiler)
(:! Host)
(get@ #store))]
(if (dict.contains? name (|> store atom.read io.run))
(ex.throw Class-Already-Stored name)
(exec (io.run (atom.update (dict.put name byte-code) store))
(#e.Success [compiler []]))))))
(def: #export (load-class name)
(-> Text (Meta (Class Object)))
(function (_ compiler)
(let [host (:! Host (get@ #.host compiler))
store (|> host (get@ #store) atom.read io.run)]
(if (dict.contains? name store)
(#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))])
(ex.throw Unknown-Class name)))))
(def: #export value-field Text "_value")
(def: #export $Object $.Type ($t.class "java.lang.Object" (list)))
(def: #export (load-definition compiler)
(-> Lux (-> Ident Blob (Error Any)))
(function (_ (^@ def-ident [def-module def-name]) def-bytecode)
(let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name)))
class-name (format (text.replace-all "/" "." def-module) "." normal-name)]
(<| (macro.run compiler)
(do macro.Monad<Meta>
[_ (..store-class class-name def-bytecode)
class (..load-class class-name)]
(case (do e.Monad<Error>
[field (Class::getField [..value-field] class)]
(Field::get [#.None] field))
(#e.Success (#.Some def-value))
(wrap def-value)
(#e.Success #.None)
(lang.throw Invalid-Definition-Value (%ident def-ident))
(#e.Error error)
(lang.throw Cannot-Load-Definition
(format "Definition: " (%ident def-ident) "\n"
"Error:\n"
error))))))))
|
