1 ----------------------------------------------------------------------
2 -- Metalua samples: $Id$
4 -- Summary: Structural pattern matching for metalua ADT.
6 ----------------------------------------------------------------------
8 -- Copyright (c) 2006-2008, Fabien Fleutot <metalua@gmail.com>.
10 -- This software is released under the MIT Licence, see licence.txt
13 --------------------------------------------------------------------------------
17 -- * term_seq: the tested stuff, a sequence of terms
18 -- * pattern_element: might match one term of a term seq. Represented
19 -- as expression ASTs.
20 -- * pattern_seq: might match a term_seq
21 -- * pattern_group: several pattern seqs, one of them might match
23 -- * case: pattern_group * guard option * block
24 -- * match_statement: tested term_seq * case list
26 -- Hence a complete match statement is a:
28 -- { list(expr), list{ list(list(expr)), expr or false, block } }
30 -- Implementation hints
31 -- ====================
33 -- The implementation is made as modular as possible, so that parts
34 -- can be reused in other extensions. The priviledged way to share
35 -- contextual information across functions is through the 'cfg' table
36 -- argument. Its fields include:
38 -- * code: code generated from pattern. A pattern_(element|seq|group)
39 -- is compiled as a sequence of instructions which will jump to
40 -- label [cfg.on_failure] if the tested term doesn't match.
42 -- * on_failure: name of the label where the code will jump if the
43 -- pattern doesn't match
45 -- * locals: names of local variables used by the pattern. This
46 -- includes bound variables, and temporary variables used to
47 -- destructure tables. Names are stored as keys of the table,
48 -- values are meaningless.
50 -- * after_success: label where the code must jump after a pattern
51 -- succeeded to capture a term, and the guard suceeded if there is
52 -- any, and the conditional block has run.
54 -- * ntmp: number of temporary variables used to destructurate table
55 -- in the current case.
57 -- Code generation is performed by acc_xxx() functions, which accumulate
60 -- * acc_test(test, cfg) will generate a jump to cfg.on_failure
61 -- *when the test returns TRUE*
63 -- * acc_stat accumulates a statement
65 -- * acc_assign accumulate an assignment statement, and makes sure that
66 -- the LHS variable the registered as local in cfg.locals.
68 ----------------------------------------------------------------------
70 -- TODO: hygiene wrt type()
71 -- TODO: cfg.ntmp isn't reset as often as it could. I'm not even sure
72 -- the corresponding locals are declared.
74 module ('spmatch', package.seeall)
76 tmpvar_base = mlp.gensym 'table_submatch.' [1]
77 function next_tmpvar(cfg)
79 if cfg.ntmp then n2=cfg.ntmp+1; cfg.ntmp=n2 else cfg.ntmp, n2 = 1, 1 end
80 return `Id{ tmpvar_base .. n2 }
84 acc_stat = |x,cfg| table.insert (cfg.code, x)
85 acc_test = |x,cfg| acc_stat(+{stat: if -{x} then -{`Goto{cfg.on_failure}} end}, cfg)
86 -- lhs :: `Id{ string }
88 function acc_assign (lhs, rhs, cfg)
90 cfg.locals[lhs[1]] = true
91 acc_stat (`Set{ {lhs}, {rhs} }, cfg)
94 literal_tags = table.transpose{ 'String', 'Number', 'True', 'False', 'Nil' }
96 -- pattern :: `Id{ string }
98 function id_pattern_element_builder (pattern, term, cfg)
99 assert (pattern.tag == "Id")
100 if pattern[1] == "_" then
101 -- "_" is used as a dummy var ==> no assignment, no == checking
103 elseif cfg.locals[pattern[1]] then
104 -- This var is already bound ==> test for equality
105 acc_test (+{ -{term} ~= -{pattern} }, cfg)
107 -- Free var ==> bind it, and remember it for latter linearity checking
108 acc_assign (pattern, term, cfg)
109 cfg.locals[pattern[1]] = true
113 -- Concatenate code in [cfg.code], that will jump to label
114 -- [cfg.on_failure] if [pattern] doesn't match [term]. [pattern]
115 -- should be an identifier, or at least cheap to compute and
116 -- side-effects free.
118 -- pattern :: pattern_element
120 function pattern_element_builder (pattern, term, cfg)
121 if literal_tags[pattern.tag] then
122 acc_test (+{ -{term} ~= -{pattern} }, cfg)
123 elseif "Id" == pattern.tag then
124 id_pattern_element_builder (pattern, term, cfg)
125 elseif "Op" == pattern.tag and "div" == pattern[1] then
126 regexp_pattern_element_builder (pattern, term, cfg)
127 elseif "Op" == pattern.tag and "eq" == pattern[1] then
128 eq_pattern_element_builder (pattern, term, cfg)
129 elseif "Table" == pattern.tag then
130 table_pattern_element_builder (pattern, term, cfg)
132 error ("Invalid pattern: "..table.tostring(pattern, "nohash"))
136 function eq_pattern_element_builder (pattern, term, cfg)
137 local _, pat1, pat2 = unpack (pattern)
138 local ntmp_save = cfg.ntmp
139 pattern_element_builder (pat1, term, cfg)
141 pattern_element_builder (pat2, term, cfg)
144 -- pattern :: `Op{ 'div', string, list{`Id string} or `Id{ string }}
146 function regexp_pattern_element_builder (pattern, term, cfg)
147 local op, regexp, sub_pattern = unpack(pattern)
150 assert (op=='div', "Don't know what to do with that op in a pattern")
151 assert (regexp.tag=="String",
152 "Left hand side operand for '/' in a pattern must be "..
153 "a literal string representing a regular expression")
154 assert (sub_pattern.tag=="Table",
155 "Right hand side operand for '/' in a pattern must be "..
156 "an identifier or a list of identifiers")
157 for x in ivalues(sub_pattern) do
158 assert (x.tag=="Id" or x.tag=='Dots',
159 "Right hand side operand for '/' in a pattern must be "..
160 "a list of identifiers")
163 -- Regexp patterns can only match strings
164 acc_test (+{ type(-{term}) ~= 'string' }, cfg)
165 -- put all captures in a list
166 local capt_list = +{ { string.strmatch(-{term}, -{regexp}) } }
167 -- save them in a var_n for recursive decomposition
168 local v2 = next_tmpvar(cfg)
169 acc_stat (+{stat: local -{v2} = -{capt_list} }, cfg)
170 -- was capture successful?
171 acc_test (+{ not next (-{v2}) }, cfg)
172 pattern_element_builder (sub_pattern, v2, cfg)
175 -- pattern :: pattern and `Table{ }
177 function table_pattern_element_builder (pattern, term, cfg)
178 local seen_dots, len = false, 0
179 acc_test (+{ type( -{term} ) ~= "table" }, cfg)
180 for i = 1, #pattern do
181 local key, sub_pattern
182 if pattern[i].tag=="Pair" then -- Explicit key/value pair
183 key, sub_pattern = unpack (pattern[i])
184 assert (literal_tags[key.tag], "Invalid key")
186 len, key, sub_pattern = len+1, `Number{ len+1 }, pattern[i]
189 -- '...' can only appear in final position
190 -- Could be fixed actually...
191 assert (not seen_dots, "Wrongly placed `...' ")
193 if sub_pattern.tag == "Id" then
194 -- Optimization: save a useless [ v(n+1)=v(n).key ]
195 id_pattern_element_builder (sub_pattern, `Index{ term, key }, cfg)
196 if sub_pattern[1] ~= "_" then
197 acc_test (+{ -{sub_pattern} == nil }, cfg)
199 elseif sub_pattern.tag == "Dots" then
200 -- Remember to suppress arity checking
203 -- Business as usual:
204 local v2 = next_tmpvar(cfg)
205 acc_assign (v2, `Index{ term, key }, cfg)
206 pattern_element_builder (sub_pattern, v2, cfg)
207 -- TODO: restore ntmp?
210 if not seen_dots then -- Check arity
211 acc_test (+{ #-{term} ~= -{`Number{len}} }, cfg)
215 -- Jumps to [cfg.on_faliure] if pattern_seq doesn't match
217 function pattern_seq_builder (pattern_seq, term_seq, cfg)
218 if #pattern_seq ~= #term_seq then error ("Bad seq arity") end
219 for i=1, #pattern_seq do
220 pattern_element_builder(pattern_seq[i], term_seq[i], cfg)
224 --------------------------------------------------
226 -- pattern_seq_builder_i:
227 -- * on failure, go to on_failure_i
228 -- * on success, go to on_success
231 -- goto after_success
232 -- label on_failure_i
233 --------------------------------------------------
234 function case_builder (case, term_seq, cfg)
235 local patterns_group, guard, block = unpack(case)
236 local on_success = mlp.gensym 'on_success' [1]
237 for i = 1, #patterns_group do
238 local pattern_seq = patterns_group[i]
239 cfg.on_failure = mlp.gensym 'match_fail' [1]
240 pattern_seq_builder(pattern_seq, term_seq, cfg)
241 if i<#patterns_group then
242 acc_stat(`Goto{on_success}, cfg)
243 acc_stat(`Label{cfg.on_failure}, cfg)
246 acc_stat (`Label{on_success}, cfg)
247 if guard then acc_test (+{not -{guard}}, cfg) end
249 acc_stat (block, cfg)
250 acc_stat (`Goto{cfg.after_success}, cfg)
251 acc_stat (`Label{cfg.on_failure}, cfg)
254 function match_builder (x)
255 local term_seq, cases = unpack(x)
258 after_success = mlp.gensym "_after_success" }
262 -- Make sure that all tested terms are variables or literals
263 for i=1, #term_seq do
264 local t = term_seq[i]
265 -- Capture problem: the following would compile wrongly:
266 -- `match x with x -> end'
267 -- Temporary workaround: suppress the condition, so that
268 -- all external variables are copied into unique names.
269 --if t.tag ~= 'Id' and not literal_tags[t.tag] then
270 local v = mlp.gensym 'v'
271 if not match_locals then match_locals = `Local{ {v}, {t} } else
272 table.insert(match_locals[1], v)
273 table.insert(match_locals[2], t)
279 if match_locals then acc_stat(match_locals, cfg) end
283 after_success = cfg.after_success,
286 case_builder (cases[i], term_seq, case_cfg)
287 if next (case_cfg.locals) then
288 local case_locals = { }
289 table.insert (case_cfg.code, 1, `Local{ case_locals, { } })
290 for v in keys (case_cfg.locals) do
291 table.insert (case_locals, `Id{ v })
294 acc_stat(case_cfg.code, cfg)
296 acc_stat(+{error 'mismatch'}, cfg)
297 acc_stat(`Label{cfg.after_success}, cfg)
301 ----------------------------------------------------------------------
302 -- Syntactical front-end
303 ----------------------------------------------------------------------
305 mlp.lexer:add{ "match", "with", "->" }
306 mlp.block.terminators:add "|"
308 match_cases_list_parser = gg.list{ name = "match cases list",
309 gg.sequence{ name = "match case",
310 gg.list{ name = "match case patterns list",
311 primary = mlp.expr_list,
313 terminators = { "->", "if" } },
314 gg.onkeyword{ "if", mlp.expr, consume = true },
318 terminators = "end" }
320 mlp.stat:add{ name = "match statement",
323 "with", gg.optkeyword "|",
324 match_cases_list_parser,
326 builder = |x| match_builder{ x[1], x[3] } }