blob: 81cdc1261e967e49a26afb2293043319d6778f37 (
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
|
(;module:
lux
(lux (control monad
["ex" exception #+ exception:]
["p" parser])
(data ["e" error]
text/format)
[meta]
(meta ["s" syntax]))
(luxc ["&" base]
(host ["$" jvm])
(lang ["ls" synthesis]
(translation [";T" common]
[";T" primitive]
[";T" structure]
[";T" eval]
[";T" procedure]
[";T" function]
[";T" reference]
[";T" case])
[";L" variable #+ Variable Register])))
(exception: #export Unrecognized-Synthesis)
(def: #export (translate synthesis)
(-> ls;Synthesis (Meta $;Inst))
(case synthesis
(^code [])
primitiveT;translate-unit
(^code [(~ singleton)])
(translate singleton)
(^template [<tag> <generator>]
[_ (<tag> value)]
(<generator> value))
([#;Bool primitiveT;translate-bool]
[#;Nat primitiveT;translate-nat]
[#;Int primitiveT;translate-int]
[#;Deg primitiveT;translate-deg]
[#;Frac primitiveT;translate-frac]
[#;Text primitiveT;translate-text])
(^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS)))
(structureT;translate-variant translate tag last? valueS)
(^code [(~@ members)])
(structureT;translate-tuple translate members)
(^ [_ (#;Form (list [_ (#;Int var)]))])
(if (variableL;captured? var)
(referenceT;translate-captured var)
(referenceT;translate-variable var))
[_ (#;Symbol definition)]
(referenceT;translate-definition definition)
(^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS)))
(caseT;translate-let translate register inputS exprS)
(^code ("lux case" (~ inputS) (~ pathPS)))
(caseT;translate-case translate inputS pathPS)
(^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS)))
[(s;run environment (p;some s;int)) (#e;Success environment)])
(functionT;translate-function translate environment arity bodyS)
(^code ("lux call" (~ functionS) (~@ argsS)))
(functionT;translate-call translate functionS argsS)
(^code ((~ [_ (#;Text procedure)]) (~@ argsS)))
(procedureT;translate-procedure translate procedure argsS)
_
(&;throw Unrecognized-Synthesis (%code synthesis))
))
|
