blob: 718175df1ea29d5c5a208a1cc353a9831b91af2d (
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
|
(;module:
lux
(lux (control monad
["ex" exception #+ exception:])
(data ["e" error]
[maybe]
[text "text/" Monoid<Text> Hash<Text>]
text/format
(coll [list "list/" Functor<List> Fold<List>]))
[meta]
[host])
(luxc ["&" base]
["&;" scope]
["&;" module]
["&;" io]
(host ["$" jvm]
(jvm ["$t" type]
["$d" def]
["$i" inst]))
(lang (translation [";T" eval]
[";T" common]))))
(exception: #export Invalid-Definition-Value)
(exception: #export Cannot-Evaluate-Definition)
(host;import java.lang.Object
(toString [] String))
(host;import java.lang.reflect.Field
(get [#? Object] #try #? Object))
(host;import (java.lang.Class c)
(getField [String] #try Field))
(def: #export (translate-def def-name valueT valueI metaI metaV)
(-> Text Type $;Inst $;Inst Code (Meta Unit))
(do meta;Monad<Meta>
[current-module meta;current-module-name
#let [def-ident [current-module def-name]
normal-name (format (&;normalize-name def-name) (%n (text/hash def-name)))
bytecode-name (format current-module "/" normal-name)
class-name (format current-module "." normal-name)
bytecode ($d;class #$;V1.6
#$;Public $;finalC
bytecode-name
(list) ["java.lang.Object" (list)]
(list)
(|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object)
($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
(|>. valueI
($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object)
$i;RETURN))))]
_ (commonT;store-class class-name bytecode)
class (commonT;load-class class-name)
valueV (: (Meta Top)
(case (do e;Monad<Error>
[field (Class.getField [commonT;value-field] class)]
(Field.get [#;None] field))
(#e;Success #;None)
(&;throw Invalid-Definition-Value (%ident def-ident))
(#e;Success (#;Some valueV))
(wrap valueV)
(#e;Error error)
(&;throw Cannot-Evaluate-Definition
(format "Definition: " (%ident def-ident) "\n"
"Error:\n"
error))))
_ (&module;define def-ident [valueT metaV valueV])
_ (if (meta;type? metaV)
(case (meta;declared-tags metaV)
#;Nil
(wrap [])
tags
(&module;declare-tags tags (meta;export? metaV) (:! Type valueV)))
(wrap []))
#let [_ (log! (format "DEF " (%ident def-ident)))]]
(commonT;record-artifact (format bytecode-name ".class") bytecode)))
(def: #export (translate-program program-args programI)
(-> Text $;Inst (Meta Unit))
(&;fail "\"lux program\" is unimplemented."))
|
