blob: e3a62308922b1b43b43e04e0237f793fb8f0ddeb (
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
141
|
(;module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
(data ["e" error]
[product]
text/format)
[meta]
(meta [type]
(type ["tc" check]))
[host])
(luxc ["&" base]
[";L" host]
(lang ["la" analysis])
["&;" module]
(generator [";G" common]))
(.. [";A" common]
[";A" function]
[";A" primitive]
[";A" reference]
[";A" structure]
[";A" procedure]))
(for {"JVM" (as-is (host;import java.lang.reflect.Method
(invoke [Object (Array Object)] #try Object))
(host;import (java.lang.Class c)
(getMethod [String (Array (Class Object))] #try Method))
(host;import java.lang.Object
(getClass [] (Class Object))
(toString [] String))
(def: _object-class (Class Object) (host;class-for Object))
(def: _apply-args
(Array (Class Object))
(|> (host;array (Class Object) +2)
(host;array-write +0 _object-class)
(host;array-write +1 _object-class)))
(def: (call-macro macro inputs)
(-> Macro (List Code) (Meta (List Code)))
(do meta;Monad<Meta>
[class (commonG;load-class hostL;function-class)]
(function [compiler]
(do e;Monad<Error>
[apply-method (Class.getMethod ["apply" _apply-args] class)
output (Method.invoke [(:! Object macro)
(|> (host;array Object +2)
(host;array-write +0 (:! Object inputs))
(host;array-write +1 (:! Object compiler)))]
apply-method)]
(:! (e;Error [Compiler (List Code)])
output))))))
})
(exception: #export Macro-Expression-Must-Have-Single-Expansion)
(exception: #export Unrecognized-Syntax)
(def: #export (analyser eval)
(-> &;Eval &;Analyser)
(: (-> Code (Meta la;Analysis))
(function analyse [ast]
(do meta;Monad<Meta>
[expectedT meta;expected-type]
(let [[cursor ast'] ast]
## The cursor must be set in the compiler for the sake
## of having useful error messages.
(&;with-cursor cursor
(case ast'
(^template [<tag> <analyser>]
(<tag> value)
(<analyser> value))
([#;Bool primitiveA;analyse-bool]
[#;Nat primitiveA;analyse-nat]
[#;Int primitiveA;analyse-int]
[#;Deg primitiveA;analyse-deg]
[#;Frac primitiveA;analyse-frac]
[#;Text primitiveA;analyse-text])
(^ (#;Tuple (list)))
primitiveA;analyse-unit
## Singleton tuples are equivalent to the element they contain.
(^ (#;Tuple (list singleton)))
(analyse singleton)
(^ (#;Tuple elems))
(structureA;analyse-product analyse elems)
(^ (#;Record pairs))
(structureA;analyse-record analyse pairs)
(#;Symbol reference)
(referenceA;analyse-reference reference)
(^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
(procedureA;analyse-procedure analyse eval proc-name proc-args)
(^template [<tag> <analyser>]
(^ (#;Form (list& [_ (<tag> tag)]
values)))
(case values
(#;Cons value #;Nil)
(<analyser> analyse tag value)
_
(<analyser> analyse tag (` [(~@ values)]))))
([#;Nat structureA;analyse-sum]
[#;Tag structureA;analyse-tagged-sum])
(#;Tag tag)
(structureA;analyse-tagged-sum analyse tag (' []))
(^ (#;Form (list& func args)))
(do meta;Monad<Meta>
[[funcT =func] (commonA;with-unknown-type
(analyse func))]
(case =func
[_ (#;Symbol def-name)]
(do @
[[def-type def-anns def-value] (meta;find-def def-name)]
(if (meta;macro? def-anns)
(do @
[expansion (function [compiler]
(case (call-macro (:! Macro def-value) args compiler)
(#e;Success [compiler' output])
(#e;Success [compiler' output])
(#e;Error error)
((&;fail error) compiler)))]
(case expansion
(^ (list single))
(analyse single)
_
(&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
(functionA;analyse-apply analyse funcT =func args)))
_
(functionA;analyse-apply analyse funcT =func args)))
_
(&;throw Unrecognized-Syntax (%code ast))
)))))))
|
