-
Notifications
You must be signed in to change notification settings - Fork 2
/
SpadCompilerPasses.spad
134 lines (111 loc) · 3.75 KB
/
SpadCompilerPasses.spad
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
)abbrev package STCLEAN SpadTreeCleanUp
SpadTreeCleanUp() : SNR == Implementation where
)include SpadTypeDefs.inc
Implementation ==> add
walk (a : APP) : N ==
fn := walk a.function
args := map(walk, a.args)
fn = ['exit] =>
-- replace "exit(1, node)" with "node"
args.1 = [1] => args.2
-- otherwise it's return statement
nodeApp(['return], args)
nodeApp(fn, args)
walk (a : ASS) : N ==
-- replace "a : T := b" with "a : T; a := b"
lv := walk a.lval
rv := walk a.rval
typeDecl? lv =>
td : TD := coerce(lv)
nodeSeq [lv, nodeAssign(td.expr, rv)]
nodeAssign(lv, rv)
walk (to : TO) ==
to := [walk to.expr, walk to.type]$TO
-- replace "fn(a, b, ...) $ T" with "(fn $ T)(a, b, ...)"
apply? to.expr =>
a : APP := coerce to.expr
nodeApp(nodeTypeOrigin(a.function, to.type), a.args)
nodeTypeOrigin(to.expr, to.type)
walk (ts : TS) ==
ts := [walk ts.expr, walk ts.type]$TS
-- replace "fn(a, b, ...) @ T" with "(fn @ T)(a, b, ...)"
apply? ts.expr =>
a : APP := coerce ts.expr
nodeApp(nodeTypeSelect(a.function, ts.type), a.args)
nodeTypeOrigin(ts.expr, ts.type)
)abbrev package SMEXP SpadMacroExpander
SpadMacroExpander() : Exports == Implementation where
)include SpadTypeDefs.inc
AL ==> Table(Symbol, SM)
Exports ==> SNR with
init : () -> Void
Implementation ==> add
import Logger('Macro)
env : Stack AL := stack [table()]
lastCtx : AL := table()
newCtx : () -> Void
newCtx () == push!(table(), env)
addCtx : AL -> Void
addCtx ctx == push!(ctx, env)
discardCtx : () -> AL
discardCtx () == pop! env
addMacro : SM -> Void
addMacro m ==
ctx := top env
ctx(m.name) := m
findMacro : Symbol -> Union(SM, "failed")
findMacro name ==
for ctx in parts env repeat
if key?(name, ctx) then
return ctx(name)
"failed"
init () ==
env := stack [table()]
lastCtx := table()
walk (s : AGG) : N ==
nodes := map(walk, s.list)
if s.kind = "Sequence" or s.kind = "Capsule" then
newCtx()
lastCtx := discardCtx()
-- eliminate leftovers after consumed macros
nodes := remove(null?, nodes)
empty? nodes => return null
nodeAgg(s.kind, nodes)
walk (app : APP) : N ==
if symbol? app.function then
m := findMacro (app.function :: Symbol)
m case SM and #m.args > 0 =>
#app.args ~= #m.args =>
fail (["Wrong number of arguments" :: PF, number(#app.args) :: PF,
"passed to macro" :: PF, string (m.name :: PF),
number(#m.args) :: PF])
error ""
newCtx()
for m_arg in m.args for arg in app.args repeat
-- skip argument rewriting if it doesn't require renaming
if not(symbol? arg and (arg :: Symbol) = m_arg) then
addMacro(nodeMacro(m_arg, [], arg) :: SM)
app' := walk m.body
discardCtx()
return app'
nodeApp(walk app.function, map(walk, app.args))
walk (m : SM) : N ==
addMacro m
null
walk (w : SW) : N ==
wenv := walk w.env
-- because w.env is always (?) a sequence it produces a valid lastCtx environment
addCtx lastCtx
wbody := walk w.body
discardCtx()
-- reduce where statement if environment contained only macros
null? wenv => wbody
nodeWhere(wbody, wenv)
walk (sym : Symbol) : N ==
m := findMacro sym
m case "failed" => [sym]
#m.args ~= 0 =>
fail (["Attempted to apply arguments to parameterless macro:" :: PF,
string(m.name :: PF)])
error ""
walk m.body