nano-bots 3.3.0 → 3.4.0

Sign up to get free protection for your applications and to get access to all the features.
@@ -24,19 +24,17 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
24
24
  io.write(table.concat(xs, "\9"))
25
25
  return io.write("\n")
26
26
  end
27
- local function default_on_error(errtype, err, lua_source)
28
- local function _616_()
29
- local _615_0 = errtype
30
- if (_615_0 == "Lua Compile") then
31
- return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n")
32
- elseif (_615_0 == "Runtime") then
27
+ local function default_on_error(errtype, err)
28
+ local function _675_()
29
+ local _674_0 = errtype
30
+ if (_674_0 == "Runtime") then
33
31
  return (compiler.traceback(tostring(err), 4) .. "\n")
34
32
  else
35
- local _ = _615_0
33
+ local _ = _674_0
36
34
  return ("%s error: %s\n"):format(errtype, tostring(err))
37
35
  end
38
36
  end
39
- return io.write(_616_())
37
+ return io.write(_675_())
40
38
  end
41
39
  local function splice_save_locals(env, lua_source, scope)
42
40
  local saves = nil
@@ -76,27 +74,28 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
76
74
  else
77
75
  gap = " "
78
76
  end
79
- local function _622_()
77
+ local function _681_()
80
78
  if next(saves) then
81
79
  return (table.concat(saves, " ") .. gap)
82
80
  else
83
81
  return ""
84
82
  end
85
83
  end
86
- local function _625_()
87
- local _623_0, _624_0 = lua_source:match("^(.*)[\n ](return .*)$")
88
- if ((nil ~= _623_0) and (nil ~= _624_0)) then
89
- local body = _623_0
90
- local _return = _624_0
84
+ local function _684_()
85
+ local _682_0, _683_0 = lua_source:match("^(.*)[\n ](return .*)$")
86
+ if ((nil ~= _682_0) and (nil ~= _683_0)) then
87
+ local body = _682_0
88
+ local _return = _683_0
91
89
  return (body .. gap .. table.concat(binds, " ") .. gap .. _return)
92
90
  else
93
- local _ = _623_0
91
+ local _ = _682_0
94
92
  return lua_source
95
93
  end
96
94
  end
97
- return (_622_() .. _625_())
95
+ return (_681_() .. _684_())
98
96
  end
99
- local function completer(env, scope, text)
97
+ local commands = {}
98
+ local function completer(env, scope, text, _3ffulltext, _from, _to)
100
99
  local max_items = 2000
101
100
  local seen = {}
102
101
  local matches = {}
@@ -106,14 +105,14 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
106
105
  local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___))
107
106
  local tbl_17_ = matches
108
107
  local i_18_ = #tbl_17_
109
- local function _627_()
108
+ local function _686_()
110
109
  if scope_first_3f then
111
110
  return scope.manglings
112
111
  else
113
112
  return tbl
114
113
  end
115
114
  end
116
- for k, is_mangled in utils.allpairs(_627_()) do
115
+ for k, is_mangled in utils.allpairs(_686_()) do
117
116
  if (max_items <= #matches) then break end
118
117
  local val_19_ = nil
119
118
  do
@@ -170,66 +169,81 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
170
169
  return descend(input, tbl, prefix0, add_matches, false)
171
170
  end
172
171
  end
173
- for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do
174
- if stop_looking_3f then break end
175
- add_matches(input_fragment, source)
172
+ do
173
+ local _695_0 = tostring((_3ffulltext or text)):match("^%s*,([^%s()[%]]*)$")
174
+ if (nil ~= _695_0) then
175
+ local cmd_fragment = _695_0
176
+ add_partials(cmd_fragment, commands, ",")
177
+ else
178
+ local _ = _695_0
179
+ for _0, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do
180
+ if stop_looking_3f then break end
181
+ add_matches(input_fragment, source)
182
+ end
183
+ end
176
184
  end
177
185
  return matches
178
186
  end
179
- local commands = {}
180
187
  local function command_3f(input)
181
188
  return input:match("^%s*,")
182
189
  end
183
190
  local function command_docs()
184
- local _636_
191
+ local _697_
185
192
  do
186
193
  local tbl_17_ = {}
187
194
  local i_18_ = #tbl_17_
188
- for name, f in pairs(commands) do
195
+ for name, f in utils.stablepairs(commands) do
189
196
  local val_19_ = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented"))
190
197
  if (nil ~= val_19_) then
191
198
  i_18_ = (i_18_ + 1)
192
199
  tbl_17_[i_18_] = val_19_
193
200
  end
194
201
  end
195
- _636_ = tbl_17_
202
+ _697_ = tbl_17_
196
203
  end
197
- return table.concat(_636_, "\n")
204
+ return table.concat(_697_, "\n")
198
205
  end
199
206
  commands.help = function(_, _0, on_values)
200
207
  return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,return FORM - Evaluate FORM and return its value to the REPL's caller.\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\nValues from previous inputs are kept in *1, *2, and *3.\n\nFor more information about the language, see https://fennel-lang.org/reference")})
201
208
  end
202
209
  do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.")
203
210
  local function reload(module_name, env, on_values, on_error)
204
- local _638_0, _639_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
205
- if ((_638_0 == true) and (nil ~= _639_0)) then
206
- local old = _639_0
211
+ local _699_0, _700_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
212
+ if ((_699_0 == true) and (nil ~= _700_0)) then
213
+ local old = _700_0
207
214
  local _ = nil
208
215
  package.loaded[module_name] = nil
209
216
  _ = nil
210
- local ok, new = pcall(require, module_name)
211
- local new0 = nil
212
- if not ok then
213
- on_values({new})
214
- new0 = old
215
- else
216
- new0 = new
217
+ local new = nil
218
+ do
219
+ local _701_0, _702_0 = pcall(require, module_name)
220
+ if ((_701_0 == true) and (nil ~= _702_0)) then
221
+ local new0 = _702_0
222
+ new = new0
223
+ elseif (true and (nil ~= _702_0)) then
224
+ local _0 = _701_0
225
+ local msg = _702_0
226
+ on_error("Repl", msg)
227
+ new = old
228
+ else
229
+ new = nil
230
+ end
217
231
  end
218
232
  specials["macro-loaded"][module_name] = nil
219
- if ((type(old) == "table") and (type(new0) == "table")) then
220
- for k, v in pairs(new0) do
233
+ if ((type(old) == "table") and (type(new) == "table")) then
234
+ for k, v in pairs(new) do
221
235
  old[k] = v
222
236
  end
223
237
  for k in pairs(old) do
224
- if (nil == new0[k]) then
238
+ if (nil == new[k]) then
225
239
  old[k] = nil
226
240
  end
227
241
  end
228
242
  package.loaded[module_name] = old
229
243
  end
230
244
  return on_values({"ok"})
231
- elseif ((_638_0 == false) and (nil ~= _639_0)) then
232
- local msg = _639_0
245
+ elseif ((_699_0 == false) and (nil ~= _700_0)) then
246
+ local msg = _700_0
233
247
  if msg:match("loop or previous error loading module") then
234
248
  package.loaded[module_name] = nil
235
249
  return reload(module_name, env, on_values, on_error)
@@ -237,32 +251,32 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
237
251
  specials["macro-loaded"][module_name] = nil
238
252
  return nil
239
253
  else
240
- local function _644_()
241
- local _643_0 = msg:gsub("\n.*", "")
242
- return _643_0
254
+ local function _707_()
255
+ local _706_0 = msg:gsub("\n.*", "")
256
+ return _706_0
243
257
  end
244
- return on_error("Runtime", _644_())
258
+ return on_error("Runtime", _707_())
245
259
  end
246
260
  end
247
261
  end
248
262
  local function run_command(read, on_error, f)
249
- local _647_0, _648_0, _649_0 = pcall(read)
250
- if ((_647_0 == true) and (_648_0 == true) and (nil ~= _649_0)) then
251
- local val = _649_0
252
- local _650_0, _651_0 = pcall(f, val)
253
- if ((_650_0 == false) and (nil ~= _651_0)) then
254
- local msg = _651_0
263
+ local _710_0, _711_0, _712_0 = pcall(read)
264
+ if ((_710_0 == true) and (_711_0 == true) and (nil ~= _712_0)) then
265
+ local val = _712_0
266
+ local _713_0, _714_0 = pcall(f, val)
267
+ if ((_713_0 == false) and (nil ~= _714_0)) then
268
+ local msg = _714_0
255
269
  return on_error("Runtime", msg)
256
270
  end
257
- elseif (_647_0 == false) then
271
+ elseif (_710_0 == false) then
258
272
  return on_error("Parse", "Couldn't parse input.")
259
273
  end
260
274
  end
261
275
  commands.reload = function(env, read, on_values, on_error)
262
- local function _654_(_241)
276
+ local function _717_(_241)
263
277
  return reload(tostring(_241), env, on_values, on_error)
264
278
  end
265
- return run_command(read, on_error, _654_)
279
+ return run_command(read, on_error, _717_)
266
280
  end
267
281
  do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.")
268
282
  commands.reset = function(env, _, on_values)
@@ -271,28 +285,28 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
271
285
  end
272
286
  do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.")
273
287
  commands.complete = function(env, read, on_values, on_error, scope, chars)
274
- local function _655_()
275
- return on_values(completer(env, scope, table.concat(chars):gsub(",complete +", ""):sub(1, -2)))
288
+ local function _718_()
289
+ return on_values(completer(env, scope, table.concat(chars):gsub("^%s*,complete%s+", ""):sub(1, -2)))
276
290
  end
277
- return run_command(read, on_error, _655_)
291
+ return run_command(read, on_error, _718_)
278
292
  end
279
293
  do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.")
280
294
  local function apropos_2a(pattern, tbl, prefix, seen, names)
281
295
  for name, subtbl in pairs(tbl) do
282
296
  if (("string" == type(name)) and (package ~= subtbl)) then
283
- local _656_0 = type(subtbl)
284
- if (_656_0 == "function") then
297
+ local _719_0 = type(subtbl)
298
+ if (_719_0 == "function") then
285
299
  if ((prefix .. name)):match(pattern) then
286
300
  table.insert(names, (prefix .. name))
287
301
  end
288
- elseif (_656_0 == "table") then
302
+ elseif (_719_0 == "table") then
289
303
  if not seen[subtbl] then
290
- local _658_
304
+ local _721_
291
305
  do
292
306
  seen[subtbl] = true
293
- _658_ = seen
307
+ _721_ = seen
294
308
  end
295
- apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _658_, names)
309
+ apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _721_, names)
296
310
  end
297
311
  end
298
312
  end
@@ -300,23 +314,13 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
300
314
  return names
301
315
  end
302
316
  local function apropos(pattern)
303
- local names = apropos_2a(pattern, package.loaded, "", {}, {})
304
- local tbl_17_ = {}
305
- local i_18_ = #tbl_17_
306
- for _, name in ipairs(names) do
307
- local val_19_ = name:gsub("^_G%.", "")
308
- if (nil ~= val_19_) then
309
- i_18_ = (i_18_ + 1)
310
- tbl_17_[i_18_] = val_19_
311
- end
312
- end
313
- return tbl_17_
317
+ return apropos_2a(pattern:gsub("^_G%.", ""), package.loaded, "", {}, {})
314
318
  end
315
319
  commands.apropos = function(_env, read, on_values, on_error, _scope)
316
- local function _663_(_241)
320
+ local function _725_(_241)
317
321
  return on_values(apropos(tostring(_241)))
318
322
  end
319
- return run_command(read, on_error, _663_)
323
+ return run_command(read, on_error, _725_)
320
324
  end
321
325
  do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.")
322
326
  local function apropos_follow_path(path)
@@ -336,12 +340,12 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
336
340
  local tgt = package.loaded
337
341
  for _, path0 in ipairs(paths) do
338
342
  if (nil == tgt) then break end
339
- local _666_
343
+ local _728_
340
344
  do
341
- local _665_0 = path0:gsub("%/", ".")
342
- _666_ = _665_0
345
+ local _727_0 = path0:gsub("%/", ".")
346
+ _728_ = _727_0
343
347
  end
344
- tgt = tgt[_666_]
348
+ tgt = tgt[_728_]
345
349
  end
346
350
  return tgt
347
351
  end
@@ -353,9 +357,9 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
353
357
  do
354
358
  local tgt = apropos_follow_path(path)
355
359
  if ("function" == type(tgt)) then
356
- local _667_0 = (compiler.metadata):get(tgt, "fnl/docstring")
357
- if (nil ~= _667_0) then
358
- local docstr = _667_0
360
+ local _729_0 = (compiler.metadata):get(tgt, "fnl/docstring")
361
+ if (nil ~= _729_0) then
362
+ local docstr = _729_0
359
363
  val_19_ = (docstr:match(pattern) and path)
360
364
  else
361
365
  val_19_ = nil
@@ -372,10 +376,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
372
376
  return tbl_17_
373
377
  end
374
378
  commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope)
375
- local function _671_(_241)
379
+ local function _733_(_241)
376
380
  return on_values(apropos_doc(tostring(_241)))
377
381
  end
378
- return run_command(read, on_error, _671_)
382
+ return run_command(read, on_error, _733_)
379
383
  end
380
384
  do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs")
381
385
  local function apropos_show_docs(on_values, pattern)
@@ -389,140 +393,142 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
389
393
  return nil
390
394
  end
391
395
  commands["apropos-show-docs"] = function(_env, read, on_values, on_error)
392
- local function _673_(_241)
396
+ local function _735_(_241)
393
397
  return apropos_show_docs(on_values, tostring(_241))
394
398
  end
395
- return run_command(read, on_error, _673_)
399
+ return run_command(read, on_error, _735_)
396
400
  end
397
401
  do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name")
398
- local function resolve(identifier, _674_0, scope)
399
- local _675_ = _674_0
400
- local env = _675_
401
- local ___replLocals___ = _675_["___replLocals___"]
402
+ local function resolve(identifier, _736_0, scope)
403
+ local _737_ = _736_0
404
+ local env = _737_
405
+ local ___replLocals___ = _737_["___replLocals___"]
402
406
  local e = nil
403
- local function _676_(_241, _242)
407
+ local function _738_(_241, _242)
404
408
  return (___replLocals___[scope.unmanglings[_242]] or env[_242])
405
409
  end
406
- e = setmetatable({}, {__index = _676_})
407
- local function _677_(...)
408
- local _678_0, _679_0 = ...
409
- if ((_678_0 == true) and (nil ~= _679_0)) then
410
- local code = _679_0
411
- local function _680_(...)
412
- local _681_0, _682_0 = ...
413
- if ((_681_0 == true) and (nil ~= _682_0)) then
414
- local val = _682_0
410
+ e = setmetatable({}, {__index = _738_})
411
+ local function _739_(...)
412
+ local _740_0, _741_0 = ...
413
+ if ((_740_0 == true) and (nil ~= _741_0)) then
414
+ local code = _741_0
415
+ local function _742_(...)
416
+ local _743_0, _744_0 = ...
417
+ if ((_743_0 == true) and (nil ~= _744_0)) then
418
+ local val = _744_0
415
419
  return val
416
420
  else
417
- local _ = _681_0
421
+ local _ = _743_0
418
422
  return nil
419
423
  end
420
424
  end
421
- return _680_(pcall(specials["load-code"](code, e)))
425
+ return _742_(pcall(specials["load-code"](code, e)))
422
426
  else
423
- local _ = _678_0
427
+ local _ = _740_0
424
428
  return nil
425
429
  end
426
430
  end
427
- return _677_(pcall(compiler["compile-string"], tostring(identifier), {scope = scope}))
431
+ return _739_(pcall(compiler["compile-string"], tostring(identifier), {scope = scope}))
428
432
  end
429
433
  commands.find = function(env, read, on_values, on_error, scope)
430
- local function _685_(_241)
431
- local _686_0 = nil
434
+ local function _747_(_241)
435
+ local _748_0 = nil
432
436
  do
433
- local _687_0 = utils["sym?"](_241)
434
- if (nil ~= _687_0) then
435
- local _688_0 = resolve(_687_0, env, scope)
436
- if (nil ~= _688_0) then
437
- _686_0 = debug.getinfo(_688_0)
437
+ local _749_0 = utils["sym?"](_241)
438
+ if (nil ~= _749_0) then
439
+ local _750_0 = resolve(_749_0, env, scope)
440
+ if (nil ~= _750_0) then
441
+ _748_0 = debug.getinfo(_750_0)
438
442
  else
439
- _686_0 = _688_0
443
+ _748_0 = _750_0
440
444
  end
441
445
  else
442
- _686_0 = _687_0
446
+ _748_0 = _749_0
443
447
  end
444
448
  end
445
- if ((_G.type(_686_0) == "table") and (nil ~= _686_0.linedefined) and (nil ~= _686_0.short_src) and (nil ~= _686_0.source) and (_686_0.what == "Lua")) then
446
- local line = _686_0.linedefined
447
- local src = _686_0.short_src
448
- local source = _686_0.source
449
+ if ((_G.type(_748_0) == "table") and (nil ~= _748_0.linedefined) and (nil ~= _748_0.short_src) and (nil ~= _748_0.source) and (_748_0.what == "Lua")) then
450
+ local line = _748_0.linedefined
451
+ local src = _748_0.short_src
452
+ local source = _748_0.source
449
453
  local fnlsrc = nil
450
454
  do
451
- local _691_0 = compiler.sourcemap
452
- if (nil ~= _691_0) then
453
- _691_0 = _691_0[source]
455
+ local _753_0 = compiler.sourcemap
456
+ if (nil ~= _753_0) then
457
+ _753_0 = _753_0[source]
454
458
  end
455
- if (nil ~= _691_0) then
456
- _691_0 = _691_0[line]
459
+ if (nil ~= _753_0) then
460
+ _753_0 = _753_0[line]
457
461
  end
458
- if (nil ~= _691_0) then
459
- _691_0 = _691_0[2]
462
+ if (nil ~= _753_0) then
463
+ _753_0 = _753_0[2]
460
464
  end
461
- fnlsrc = _691_0
465
+ fnlsrc = _753_0
462
466
  end
463
467
  return on_values({string.format("%s:%s", src, (fnlsrc or line))})
464
- elseif (_686_0 == nil) then
468
+ elseif (_748_0 == nil) then
465
469
  return on_error("Repl", "Unknown value")
466
470
  else
467
- local _ = _686_0
471
+ local _ = _748_0
468
472
  return on_error("Repl", "No source info")
469
473
  end
470
474
  end
471
- return run_command(read, on_error, _685_)
475
+ return run_command(read, on_error, _747_)
472
476
  end
473
477
  do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function")
474
478
  commands.doc = function(env, read, on_values, on_error, scope)
475
- local function _696_(_241)
479
+ local function _758_(_241)
476
480
  local name = tostring(_241)
477
481
  local path = (utils["multi-sym?"](name) or {name})
478
482
  local ok_3f, target = nil, nil
479
- local function _697_()
480
- return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope))
483
+ local function _759_()
484
+ return (scope.specials[name] or utils["get-in"](scope.macros, path) or resolve(name, env, scope))
481
485
  end
482
- ok_3f, target = pcall(_697_)
486
+ ok_3f, target = pcall(_759_)
483
487
  if ok_3f then
484
488
  return on_values({specials.doc(target, name)})
485
489
  else
486
490
  return on_error("Repl", ("Could not find " .. name .. " for docs."))
487
491
  end
488
492
  end
489
- return run_command(read, on_error, _696_)
493
+ return run_command(read, on_error, _758_)
490
494
  end
491
495
  do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.")
492
- commands.compile = function(env, read, on_values, on_error, scope)
493
- local function _699_(_241)
494
- local allowedGlobals = specials["current-global-names"](env)
495
- local ok_3f, result = pcall(compiler.compile, _241, {allowedGlobals = allowedGlobals, env = env, scope = scope})
496
- if ok_3f then
496
+ commands.compile = function(_, read, on_values, on_error, _0, _1, opts)
497
+ local function _761_(_241)
498
+ local _762_0, _763_0 = pcall(compiler.compile, _241, opts)
499
+ if ((_762_0 == true) and (nil ~= _763_0)) then
500
+ local result = _763_0
497
501
  return on_values({result})
498
- else
499
- return on_error("Repl", ("Error compiling expression: " .. result))
502
+ elseif (true and (nil ~= _763_0)) then
503
+ local _2 = _762_0
504
+ local msg = _763_0
505
+ return on_error("Repl", ("Error compiling expression: " .. msg))
500
506
  end
501
507
  end
502
- return run_command(read, on_error, _699_)
508
+ return run_command(read, on_error, _761_)
503
509
  end
504
510
  do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.")
505
511
  local function load_plugin_commands(plugins)
506
512
  for i = #(plugins or {}), 1, -1 do
507
513
  for name, f in pairs(plugins[i]) do
508
- local _701_0 = name:match("^repl%-command%-(.*)")
509
- if (nil ~= _701_0) then
510
- local cmd_name = _701_0
514
+ local _765_0 = name:match("^repl%-command%-(.*)")
515
+ if (nil ~= _765_0) then
516
+ local cmd_name = _765_0
511
517
  commands[cmd_name] = f
512
518
  end
513
519
  end
514
520
  end
515
521
  return nil
516
522
  end
517
- local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars)
523
+ local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars, opts)
518
524
  local command_name = input:match(",([^%s/]+)")
519
525
  do
520
- local _703_0 = commands[command_name]
521
- if (nil ~= _703_0) then
522
- local command = _703_0
523
- command(env, read, on_values, on_error, scope, chars)
526
+ local _767_0 = commands[command_name]
527
+ if (nil ~= _767_0) then
528
+ local command = _767_0
529
+ command(env, read, on_values, on_error, scope, chars, opts)
524
530
  else
525
- local _ = _703_0
531
+ local _ = _767_0
526
532
  if ((command_name ~= "exit") and (command_name ~= "return")) then
527
533
  on_values({"Unknown command", command_name})
528
534
  end
@@ -558,7 +564,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
558
564
  local function repl_completer(text, from, to)
559
565
  if completer0 then
560
566
  readline.set_completion_append_character("")
561
- return completer0(text:sub(from, to))
567
+ return completer0(text:sub(from, to), text, from, to)
562
568
  else
563
569
  return {}
564
570
  end
@@ -572,9 +578,9 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
572
578
  end
573
579
  local function repl(_3foptions)
574
580
  local old_root_options = utils.root.options
575
- local _712_ = utils.copy(_3foptions)
576
- local opts = _712_
577
- local _3ffennelrc = _712_["fennelrc"]
581
+ local _776_ = utils.copy(_3foptions)
582
+ local opts = _776_
583
+ local _3ffennelrc = _776_["fennelrc"]
578
584
  local _ = nil
579
585
  opts.fennelrc = nil
580
586
  _ = nil
@@ -586,23 +592,23 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
586
592
  _0 = nil
587
593
  end
588
594
  local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G))
589
- local callbacks = {env = env, onError = (opts.onError or default_on_error), onValues = (opts.onValues or default_on_values), pp = (opts.pp or view), readChunk = (opts.readChunk or default_read_chunk)}
595
+ local callbacks = {["view-opts"] = (opts["view-opts"] or {depth = 4}), env = env, onError = (opts.onError or default_on_error), onValues = (opts.onValues or default_on_values), pp = (opts.pp or view), readChunk = (opts.readChunk or default_read_chunk)}
590
596
  local save_locals_3f = (opts.saveLocals ~= false)
591
597
  local byte_stream, clear_stream = nil, nil
592
- local function _714_(_241)
598
+ local function _778_(_241)
593
599
  return callbacks.readChunk(_241)
594
600
  end
595
- byte_stream, clear_stream = parser.granulate(_714_)
601
+ byte_stream, clear_stream = parser.granulate(_778_)
596
602
  local chars = {}
597
603
  local read, reset = nil, nil
598
- local function _715_(parser_state)
604
+ local function _779_(parser_state)
599
605
  local b = byte_stream(parser_state)
600
606
  if b then
601
607
  table.insert(chars, string.char(b))
602
608
  end
603
609
  return b
604
610
  end
605
- read, reset = parser.parser(_715_)
611
+ read, reset = parser.parser(_779_)
606
612
  depth = (depth + 1)
607
613
  if opts.message then
608
614
  callbacks.onValues({opts.message})
@@ -617,14 +623,14 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
617
623
  opts.init(opts, depth)
618
624
  end
619
625
  if opts.registerCompleter then
620
- local function _721_()
621
- local _720_0 = opts.scope
622
- local function _722_(...)
623
- return completer(env, _720_0, ...)
626
+ local function _785_()
627
+ local _784_0 = opts.scope
628
+ local function _786_(...)
629
+ return completer(env, _784_0, ...)
624
630
  end
625
- return _722_
631
+ return _786_
626
632
  end
627
- opts.registerCompleter(_721_())
633
+ opts.registerCompleter(_785_())
628
634
  end
629
635
  load_plugin_commands(opts.plugins)
630
636
  if save_locals_3f then
@@ -641,7 +647,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
641
647
  local pp = callbacks.pp
642
648
  env._, env.__ = vals[1], vals
643
649
  for i = 1, select("#", ...) do
644
- table.insert(out, pp(vals[i]))
650
+ table.insert(out, pp(vals[i], callbacks["view-opts"]))
645
651
  end
646
652
  return callbacks.onValues(out)
647
653
  end
@@ -668,31 +674,31 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
668
674
  clear_stream()
669
675
  return loop()
670
676
  elseif command_3f(src_string) then
671
- return run_command_loop(src_string, read, loop, env, callbacks.onValues, callbacks.onError, opts.scope, chars)
677
+ return run_command_loop(src_string, read, loop, env, callbacks.onValues, callbacks.onError, opts.scope, chars, opts)
672
678
  else
673
679
  if not_eof_3f then
674
- local function _726_(...)
675
- local _727_0, _728_0 = ...
676
- if ((_727_0 == true) and (nil ~= _728_0)) then
677
- local src = _728_0
678
- local function _729_(...)
679
- local _730_0, _731_0 = ...
680
- if ((_730_0 == true) and (nil ~= _731_0)) then
681
- local chunk = _731_0
682
- local function _732_()
680
+ local function _790_(...)
681
+ local _791_0, _792_0 = ...
682
+ if ((_791_0 == true) and (nil ~= _792_0)) then
683
+ local src = _792_0
684
+ local function _793_(...)
685
+ local _794_0, _795_0 = ...
686
+ if ((_794_0 == true) and (nil ~= _795_0)) then
687
+ local chunk = _795_0
688
+ local function _796_()
683
689
  return print_values(save_value(chunk()))
684
690
  end
685
- local function _733_(...)
691
+ local function _797_(...)
686
692
  return callbacks.onError("Runtime", ...)
687
693
  end
688
- return xpcall(_732_, _733_)
689
- elseif ((_730_0 == false) and (nil ~= _731_0)) then
690
- local msg = _731_0
694
+ return xpcall(_796_, _797_)
695
+ elseif ((_794_0 == false) and (nil ~= _795_0)) then
696
+ local msg = _795_0
691
697
  clear_stream()
692
698
  return callbacks.onError("Compile", msg)
693
699
  end
694
700
  end
695
- local function _736_(...)
701
+ local function _800_(...)
696
702
  local src0 = nil
697
703
  if save_locals_3f then
698
704
  src0 = splice_save_locals(env, src, opts.scope)
@@ -701,18 +707,18 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
701
707
  end
702
708
  return pcall(specials["load-code"], src0, env)
703
709
  end
704
- return _729_(_736_(...))
705
- elseif ((_727_0 == false) and (nil ~= _728_0)) then
706
- local msg = _728_0
710
+ return _793_(_800_(...))
711
+ elseif ((_791_0 == false) and (nil ~= _792_0)) then
712
+ local msg = _792_0
707
713
  clear_stream()
708
714
  return callbacks.onError("Compile", msg)
709
715
  end
710
716
  end
711
- local function _738_()
717
+ local function _802_()
712
718
  opts["source"] = src_string
713
719
  return opts
714
720
  end
715
- _726_(pcall(compiler.compile, form, _738_()))
721
+ _790_(pcall(compiler.compile, form, _802_()))
716
722
  utils.root.options = old_root_options
717
723
  if exit_next_3f then
718
724
  return env.___replLocals___["*1"]
@@ -732,10 +738,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
732
738
  end
733
739
  return value
734
740
  end
735
- local function _744_(overrides, _3fopts)
741
+ local function _808_(overrides, _3fopts)
736
742
  return repl(utils.copy(_3fopts, utils.copy(overrides)))
737
743
  end
738
- return setmetatable({}, {__call = _744_, __index = {repl = repl}})
744
+ return setmetatable({}, {__call = _808_, __index = {repl = repl}})
739
745
  end
740
746
  package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...)
741
747
  local utils = require("fennel.utils")
@@ -744,15 +750,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
744
750
  local compiler = require("fennel.compiler")
745
751
  local unpack = (table.unpack or _G.unpack)
746
752
  local SPECIALS = compiler.scopes.global.specials
753
+ local function str1(x)
754
+ return tostring(x[1])
755
+ end
747
756
  local function wrap_env(env)
748
- local function _420_(_, key)
757
+ local function _449_(_, key)
749
758
  if utils["string?"](key) then
750
759
  return env[compiler["global-unmangling"](key)]
751
760
  else
752
761
  return env[key]
753
762
  end
754
763
  end
755
- local function _422_(_, key, value)
764
+ local function _451_(_, key, value)
756
765
  if utils["string?"](key) then
757
766
  env[compiler["global-unmangling"](key)] = value
758
767
  return nil
@@ -761,19 +770,28 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
761
770
  return nil
762
771
  end
763
772
  end
764
- local function _424_()
765
- local function putenv(k, v)
766
- local _425_
767
- if utils["string?"](k) then
768
- _425_ = compiler["global-unmangling"](k)
769
- else
770
- _425_ = k
773
+ local function _453_()
774
+ local _454_
775
+ do
776
+ local tbl_14_ = {}
777
+ for k, v in utils.stablepairs(env) do
778
+ local k_15_, v_16_ = nil, nil
779
+ local _455_
780
+ if utils["string?"](k) then
781
+ _455_ = compiler["global-unmangling"](k)
782
+ else
783
+ _455_ = k
784
+ end
785
+ k_15_, v_16_ = _455_, v
786
+ if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
787
+ tbl_14_[k_15_] = v_16_
788
+ end
771
789
  end
772
- return _425_, v
790
+ _454_ = tbl_14_
773
791
  end
774
- return next, utils.kvmap(env, putenv), nil
792
+ return next, _454_, nil
775
793
  end
776
- return setmetatable({}, {__index = _420_, __newindex = _422_, __pairs = _424_})
794
+ return setmetatable({}, {__index = _449_, __newindex = _451_, __pairs = _453_})
777
795
  end
778
796
  local function fennel_module_name()
779
797
  return (utils.root.options.moduleName or "fennel")
@@ -781,9 +799,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
781
799
  local function current_global_names(_3fenv)
782
800
  local mt = nil
783
801
  do
784
- local _427_0 = getmetatable(_3fenv)
785
- if ((_G.type(_427_0) == "table") and (nil ~= _427_0.__pairs)) then
786
- local mtpairs = _427_0.__pairs
802
+ local _458_0 = getmetatable(_3fenv)
803
+ if ((_G.type(_458_0) == "table") and (nil ~= _458_0.__pairs)) then
804
+ local mtpairs = _458_0.__pairs
787
805
  local tbl_14_ = {}
788
806
  for k, v in mtpairs(_3fenv) do
789
807
  local k_15_, v_16_ = k, v
@@ -792,25 +810,37 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
792
810
  end
793
811
  end
794
812
  mt = tbl_14_
795
- elseif (_427_0 == nil) then
813
+ elseif (_458_0 == nil) then
796
814
  mt = (_3fenv or _G)
797
815
  else
798
816
  mt = nil
799
817
  end
800
818
  end
801
- return (mt and utils.kvmap(mt, compiler["global-unmangling"]))
819
+ local function _461_()
820
+ local tbl_17_ = {}
821
+ local i_18_ = #tbl_17_
822
+ for k, v in utils.stablepairs(mt) do
823
+ local val_19_ = compiler["global-unmangling"](k)
824
+ if (nil ~= val_19_) then
825
+ i_18_ = (i_18_ + 1)
826
+ tbl_17_[i_18_] = val_19_
827
+ end
828
+ end
829
+ return tbl_17_
830
+ end
831
+ return (mt and _461_())
802
832
  end
803
833
  local function load_code(code, _3fenv, _3ffilename)
804
834
  local env = (_3fenv or rawget(_G, "_ENV") or _G)
805
- local _430_0, _431_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring")
806
- if ((nil ~= _430_0) and (nil ~= _431_0)) then
807
- local setfenv = _430_0
808
- local loadstring = _431_0
835
+ local _463_0, _464_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring")
836
+ if ((nil ~= _463_0) and (nil ~= _464_0)) then
837
+ local setfenv = _463_0
838
+ local loadstring = _464_0
809
839
  local f = assert(loadstring(code, _3ffilename))
810
840
  setfenv(f, env)
811
841
  return f
812
842
  else
813
- local _ = _430_0
843
+ local _ = _463_0
814
844
  return assert(load(code, _3ffilename, "t", env))
815
845
  end
816
846
  end
@@ -821,14 +851,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
821
851
  local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#<undocumented>")):gsub("\n$", ""):gsub("\n", "\n ")
822
852
  local mt = getmetatable(tgt)
823
853
  if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then
824
- local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#<unknown-arguments>"}), " ")
825
- local _433_
826
- if (0 < #arglist) then
827
- _433_ = " "
828
- else
829
- _433_ = ""
854
+ local elts = nil
855
+ do
856
+ local _466_0 = ((compiler.metadata):get(tgt, "fnl/arglist") or {"#<unknown-arguments>"})
857
+ table.insert(_466_0, 1, name)
858
+ elts = _466_0
830
859
  end
831
- return string.format("(%s%s%s)\n %s", name, _433_, arglist, docstring)
860
+ return string.format("(%s)\n %s", table.concat(elts, " "), docstring)
832
861
  else
833
862
  return string.format("%s\n %s", name, docstring)
834
863
  end
@@ -895,13 +924,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
895
924
  end
896
925
  end
897
926
  doc_special("do", {"..."}, "Evaluate multiple forms; return last value.", true)
927
+ local function iter_args(ast)
928
+ local ast0, len, i = ast, #ast, 1
929
+ local function _472_()
930
+ i = (1 + i)
931
+ while ((i == len) and utils["call-of?"](ast0[i], "values")) do
932
+ ast0 = ast0[i]
933
+ len = #ast0
934
+ i = 2
935
+ end
936
+ return ast0[i], (nil == ast0[(i + 1)])
937
+ end
938
+ return _472_
939
+ end
898
940
  SPECIALS.values = function(ast, scope, parent)
899
- local len = #ast
900
941
  local exprs = {}
901
- for i = 2, len do
902
- local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)})
942
+ for subast, last_3f in iter_args(ast) do
943
+ local subexprs = compiler.compile1(subast, scope, parent, {nval = (not last_3f and 1)})
903
944
  table.insert(exprs, subexprs[1])
904
- if (i == len) then
945
+ if last_3f then
905
946
  for j = 2, #subexprs do
906
947
  table.insert(exprs, subexprs[j])
907
948
  end
@@ -938,9 +979,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
938
979
  local opts = {nval = 1, tail = false}
939
980
  local scope = compiler["make-scope"]()
940
981
  local chunk = {}
941
- local _443_ = compiler.compile1(v, scope, chunk, opts)
942
- local _444_ = _443_[1]
943
- local v0 = _444_[1]
982
+ local _476_ = compiler.compile1(v, scope, chunk, opts)
983
+ local _477_ = _476_[1]
984
+ local v0 = _477_[1]
944
985
  return v0
945
986
  end
946
987
  local function insert_meta(meta, k, v)
@@ -948,23 +989,33 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
948
989
  compiler.assert((type(k) == "string"), ("expected string keys in metadata table, got: %s"):format(view(k, view_opts)))
949
990
  compiler.assert(literal_3f(v), ("expected literal value in metadata table, got: %s %s"):format(view(k, view_opts), view(v, view_opts)))
950
991
  table.insert(meta, view(k))
951
- local function _445_()
992
+ local function _478_()
952
993
  if ("string" == type(v)) then
953
994
  return view(v, view_opts)
954
995
  else
955
996
  return compile_value(v)
956
997
  end
957
998
  end
958
- table.insert(meta, _445_())
999
+ table.insert(meta, _478_())
959
1000
  return meta
960
1001
  end
961
1002
  local function insert_arglist(meta, arg_list)
962
- local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true}
963
- table.insert(meta, "\"fnl/arglist\"")
964
- local function _446_(_241)
965
- return view(view(_241, view_opts))
1003
+ local opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true}
1004
+ local view_args = nil
1005
+ do
1006
+ local tbl_17_ = {}
1007
+ local i_18_ = #tbl_17_
1008
+ for _, arg in ipairs(arg_list) do
1009
+ local val_19_ = view(view(arg, opts))
1010
+ if (nil ~= val_19_) then
1011
+ i_18_ = (i_18_ + 1)
1012
+ tbl_17_[i_18_] = val_19_
1013
+ end
1014
+ end
1015
+ view_args = tbl_17_
966
1016
  end
967
- table.insert(meta, ("{" .. table.concat(utils.map(arg_list, _446_), ", ") .. "}"))
1017
+ table.insert(meta, "\"fnl/arglist\"")
1018
+ table.insert(meta, ("{" .. table.concat(view_args, ", ") .. "}"))
968
1019
  return meta
969
1020
  end
970
1021
  local function set_fn_metadata(f_metadata, parent, fn_name)
@@ -983,13 +1034,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
983
1034
  end
984
1035
  local function get_fn_name(ast, scope, fn_name, multi)
985
1036
  if (fn_name and (fn_name[1] ~= "nil")) then
986
- local _449_
1037
+ local _482_
987
1038
  if not multi then
988
- _449_ = compiler["declare-local"](fn_name, {}, scope, ast)
1039
+ _482_ = compiler["declare-local"](fn_name, scope, ast)
989
1040
  else
990
- _449_ = compiler["symbol-to-expression"](fn_name, scope)[1]
1041
+ _482_ = compiler["symbol-to-expression"](fn_name, scope)[1]
991
1042
  end
992
- return _449_, not multi, 3
1043
+ return _482_, not multi, 3
993
1044
  else
994
1045
  return nil, true, 2
995
1046
  end
@@ -999,13 +1050,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
999
1050
  for i = (index + 1), #ast do
1000
1051
  compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
1001
1052
  end
1002
- local _452_
1053
+ local _485_
1003
1054
  if local_3f then
1004
- _452_ = "local function %s(%s)"
1055
+ _485_ = "local function %s(%s)"
1005
1056
  else
1006
- _452_ = "%s = function(%s)"
1057
+ _485_ = "%s = function(%s)"
1007
1058
  end
1008
- compiler.emit(parent, string.format(_452_, fn_name, table.concat(arg_name_list, ", ")), ast)
1059
+ compiler.emit(parent, string.format(_485_, fn_name, table.concat(arg_name_list, ", ")), ast)
1009
1060
  compiler.emit(parent, f_chunk, ast)
1010
1061
  compiler.emit(parent, "end", ast)
1011
1062
  set_fn_metadata(f_metadata, parent, fn_name)
@@ -1027,7 +1078,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1027
1078
  end
1028
1079
  end
1029
1080
  local function get_function_metadata(ast, arg_list, index)
1030
- local function _455_(_241, _242)
1081
+ local function _488_(_241, _242)
1031
1082
  local tbl_14_ = _241
1032
1083
  for k, v in pairs(_242) do
1033
1084
  local k_15_, v_16_ = k, v
@@ -1037,28 +1088,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1037
1088
  end
1038
1089
  return tbl_14_
1039
1090
  end
1040
- local function _457_(_241, _242)
1091
+ local function _490_(_241, _242)
1041
1092
  _241["fnl/docstring"] = _242
1042
1093
  return _241
1043
1094
  end
1044
- return maybe_metadata(ast, utils["kv-table?"], _455_, maybe_metadata(ast, utils["string?"], _457_, {["fnl/arglist"] = arg_list}, index))
1095
+ return maybe_metadata(ast, utils["kv-table?"], _488_, maybe_metadata(ast, utils["string?"], _490_, {["fnl/arglist"] = arg_list}, index))
1045
1096
  end
1046
- SPECIALS.fn = function(ast, scope, parent)
1097
+ SPECIALS.fn = function(ast, scope, parent, opts)
1047
1098
  local f_scope = nil
1048
1099
  do
1049
- local _458_0 = compiler["make-scope"](scope)
1050
- _458_0["vararg"] = false
1051
- f_scope = _458_0
1100
+ local _491_0 = compiler["make-scope"](scope)
1101
+ _491_0["vararg"] = false
1102
+ f_scope = _491_0
1052
1103
  end
1053
1104
  local f_chunk = {}
1054
1105
  local fn_sym = utils["sym?"](ast[2])
1055
1106
  local multi = (fn_sym and utils["multi-sym?"](fn_sym[1]))
1056
- local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi)
1107
+ local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi, opts)
1057
1108
  local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast)
1058
1109
  compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym)
1110
+ if (multi and not scope.symmeta[multi[1]] and not compiler["global-allowed?"](multi[1])) then
1111
+ compiler.assert(nil, ("expected local table " .. multi[1]), ast[2])
1112
+ end
1059
1113
  local function destructure_arg(arg)
1060
1114
  local raw = utils.sym(compiler.gensym(scope))
1061
- local declared = compiler["declare-local"](raw, {}, f_scope, ast)
1115
+ local declared = compiler["declare-local"](raw, f_scope, ast)
1062
1116
  compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"})
1063
1117
  return declared
1064
1118
  end
@@ -1078,7 +1132,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1078
1132
  elseif utils["sym?"](arg, "&") then
1079
1133
  return destructure_amp(i)
1080
1134
  elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then
1081
- return compiler["declare-local"](arg, {}, f_scope, ast)
1135
+ return compiler["declare-local"](arg, f_scope, ast)
1082
1136
  elseif utils["table?"](arg) then
1083
1137
  return destructure_arg(arg)
1084
1138
  else
@@ -1108,28 +1162,28 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1108
1162
  doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true)
1109
1163
  SPECIALS.lua = function(ast, _, parent)
1110
1164
  compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast)
1111
- local _463_
1165
+ local _497_
1112
1166
  do
1113
- local _462_0 = utils["sym?"](ast[2])
1114
- if (nil ~= _462_0) then
1115
- _463_ = tostring(_462_0)
1167
+ local _496_0 = utils["sym?"](ast[2])
1168
+ if (nil ~= _496_0) then
1169
+ _497_ = tostring(_496_0)
1116
1170
  else
1117
- _463_ = _462_0
1171
+ _497_ = _496_0
1118
1172
  end
1119
1173
  end
1120
- if ("nil" ~= _463_) then
1174
+ if ("nil" ~= _497_) then
1121
1175
  table.insert(parent, {ast = ast, leaf = tostring(ast[2])})
1122
1176
  end
1123
- local _467_
1177
+ local _501_
1124
1178
  do
1125
- local _466_0 = utils["sym?"](ast[3])
1126
- if (nil ~= _466_0) then
1127
- _467_ = tostring(_466_0)
1179
+ local _500_0 = utils["sym?"](ast[3])
1180
+ if (nil ~= _500_0) then
1181
+ _501_ = tostring(_500_0)
1128
1182
  else
1129
- _467_ = _466_0
1183
+ _501_ = _500_0
1130
1184
  end
1131
1185
  end
1132
- if ("nil" ~= _467_) then
1186
+ if ("nil" ~= _501_) then
1133
1187
  return tostring(ast[3])
1134
1188
  end
1135
1189
  end
@@ -1137,8 +1191,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1137
1191
  compiler.assert((1 < #ast), "expected table argument", ast)
1138
1192
  local len = #ast
1139
1193
  local lhs_node = compiler.macroexpand(ast[2], scope)
1140
- local _470_ = compiler.compile1(lhs_node, scope, parent, {nval = 1})
1141
- local lhs = _470_[1]
1194
+ local _504_ = compiler.compile1(lhs_node, scope, parent, {nval = 1})
1195
+ local lhs = _504_[1]
1142
1196
  if (len == 2) then
1143
1197
  return tostring(lhs)
1144
1198
  else
@@ -1148,8 +1202,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1148
1202
  if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then
1149
1203
  table.insert(indices, ("." .. index))
1150
1204
  else
1151
- local _471_ = compiler.compile1(index, scope, parent, {nval = 1})
1152
- local index0 = _471_[1]
1205
+ local _505_ = compiler.compile1(index, scope, parent, {nval = 1})
1206
+ local index0 = _505_[1]
1153
1207
  table.insert(indices, ("[" .. tostring(index0) .. "]"))
1154
1208
  end
1155
1209
  end
@@ -1167,7 +1221,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1167
1221
  compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"})
1168
1222
  return nil
1169
1223
  end
1170
- doc_special("global", {"name", "val"}, "Set name as a global with val.")
1224
+ doc_special("global", {"name", "val"}, "Set name as a global with val. Deprecated.")
1171
1225
  SPECIALS.set = function(ast, scope, parent)
1172
1226
  compiler.assert((#ast == 3), "expected name and value", ast)
1173
1227
  compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"})
@@ -1180,21 +1234,23 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1180
1234
  return nil
1181
1235
  end
1182
1236
  SPECIALS["set-forcibly!"] = set_forcibly_21_2a
1183
- local function local_2a(ast, scope, parent)
1237
+ local function local_2a(ast, scope, parent, opts)
1238
+ compiler.assert(((0 == opts.nval) or opts.tail), "can't introduce local here", ast)
1184
1239
  compiler.assert((#ast == 3), "expected name and value", ast)
1185
1240
  compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"})
1186
1241
  return nil
1187
1242
  end
1188
1243
  SPECIALS["local"] = local_2a
1189
1244
  doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.")
1190
- SPECIALS.var = function(ast, scope, parent)
1245
+ SPECIALS.var = function(ast, scope, parent, opts)
1246
+ compiler.assert(((0 == opts.nval) or opts.tail), "can't introduce var here", ast)
1191
1247
  compiler.assert((#ast == 3), "expected name and value", ast)
1192
1248
  compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"})
1193
1249
  return nil
1194
1250
  end
1195
1251
  doc_special("var", {"name", "val"}, "Introduce new mutable local.")
1196
1252
  local function kv_3f(t)
1197
- local _475_
1253
+ local _509_
1198
1254
  do
1199
1255
  local tbl_17_ = {}
1200
1256
  local i_18_ = #tbl_17_
@@ -1210,18 +1266,30 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1210
1266
  tbl_17_[i_18_] = val_19_
1211
1267
  end
1212
1268
  end
1213
- _475_ = tbl_17_
1269
+ _509_ = tbl_17_
1214
1270
  end
1215
- return _475_[1]
1271
+ return _509_[1]
1216
1272
  end
1217
- SPECIALS.let = function(ast, scope, parent, opts)
1218
- local bindings = ast[2]
1219
- local pre_syms = {}
1220
- compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", bindings)
1221
- compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2])
1273
+ SPECIALS.let = function(_512_0, scope, parent, opts)
1274
+ local _513_ = _512_0
1275
+ local _ = _513_[1]
1276
+ local bindings = _513_[2]
1277
+ local ast = _513_
1278
+ compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", (bindings or ast[1]))
1279
+ compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", bindings)
1222
1280
  compiler.assert((3 <= #ast), "expected body expression", ast[1])
1223
- for _ = 1, (opts.nval or 0) do
1224
- table.insert(pre_syms, compiler.gensym(scope))
1281
+ local pre_syms = nil
1282
+ do
1283
+ local tbl_17_ = {}
1284
+ local i_18_ = #tbl_17_
1285
+ for _0 = 1, (opts.nval or 0) do
1286
+ local val_19_ = compiler.gensym(scope)
1287
+ if (nil ~= val_19_) then
1288
+ i_18_ = (i_18_ + 1)
1289
+ tbl_17_[i_18_] = val_19_
1290
+ end
1291
+ end
1292
+ pre_syms = tbl_17_
1225
1293
  end
1226
1294
  local sub_scope = compiler["make-scope"](scope)
1227
1295
  local sub_chunk = {}
@@ -1238,36 +1306,42 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1238
1306
  return (parent or "")
1239
1307
  end
1240
1308
  end
1241
- local function disambiguate_3f(rootstr, parent)
1242
- local function _480_()
1243
- local _479_0 = get_prev_line(parent)
1244
- if (nil ~= _479_0) then
1245
- local prev_line = _479_0
1246
- return prev_line:match("%)$")
1247
- end
1248
- end
1249
- return (rootstr:match("^{") or rootstr:match("^%(") or _480_())
1309
+ local function needs_separator_3f(root, prev_line)
1310
+ return (root:match("^%(") and prev_line and not prev_line:find(" end$"))
1250
1311
  end
1251
1312
  SPECIALS.tset = function(ast, scope, parent)
1252
1313
  compiler.assert((3 < #ast), "expected table, key, and value arguments", ast)
1253
- local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
1254
- local keys = {}
1255
- for i = 3, (#ast - 1) do
1256
- local _482_ = compiler.compile1(ast[i], scope, parent, {nval = 1})
1257
- local key = _482_[1]
1258
- table.insert(keys, tostring(key))
1314
+ compiler.assert(((type(ast[2]) ~= "boolean") and (type(ast[2]) ~= "number")), "cannot set field of literal value", ast)
1315
+ local root = str1(compiler.compile1(ast[2], scope, parent, {nval = 1}))
1316
+ local root0 = nil
1317
+ if root:match("^[.{\"]") then
1318
+ root0 = string.format("(%s)", root)
1319
+ else
1320
+ root0 = root
1321
+ end
1322
+ local keys = nil
1323
+ do
1324
+ local tbl_17_ = {}
1325
+ local i_18_ = #tbl_17_
1326
+ for i = 3, (#ast - 1) do
1327
+ local val_19_ = str1(compiler.compile1(ast[i], scope, parent, {nval = 1}))
1328
+ if (nil ~= val_19_) then
1329
+ i_18_ = (i_18_ + 1)
1330
+ tbl_17_[i_18_] = val_19_
1331
+ end
1332
+ end
1333
+ keys = tbl_17_
1259
1334
  end
1260
- local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1]
1261
- local rootstr = tostring(root)
1335
+ local value = str1(compiler.compile1(ast[#ast], scope, parent, {nval = 1}))
1262
1336
  local fmtstr = nil
1263
- if disambiguate_3f(rootstr, parent) then
1264
- fmtstr = "do end (%s)[%s] = %s"
1337
+ if needs_separator_3f(root0, get_prev_line(parent)) then
1338
+ fmtstr = "do end %s[%s] = %s"
1265
1339
  else
1266
1340
  fmtstr = "%s[%s] = %s"
1267
1341
  end
1268
- return compiler.emit(parent, fmtstr:format(rootstr, table.concat(keys, "]["), tostring(value)), ast)
1342
+ return compiler.emit(parent, fmtstr:format(root0, table.concat(keys, "]["), value), ast)
1269
1343
  end
1270
- doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Can take additional keys to set\nnested values, but all parents must contain an existing table.")
1344
+ doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Deprecated in favor of set.")
1271
1345
  local function calculate_if_target(scope, opts)
1272
1346
  if not (opts.tail or opts.target or opts.nval) then
1273
1347
  return "iife", true, nil
@@ -1307,8 +1381,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1307
1381
  end
1308
1382
  for i = 2, (#ast - 1), 2 do
1309
1383
  local condchunk = {}
1310
- local res = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1})
1311
- local cond = res[1]
1384
+ local _522_ = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1})
1385
+ local cond = _522_[1]
1312
1386
  local branch = compile_body((i + 1))
1313
1387
  branch.cond = cond
1314
1388
  branch.condchunk = condchunk
@@ -1378,10 +1452,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1378
1452
  local function remove_until_condition(bindings, ast)
1379
1453
  local _until = nil
1380
1454
  for i = (#bindings - 1), 3, -1 do
1381
- local _492_0 = clause_3f(bindings[i])
1382
- if ((_492_0 == false) or (_492_0 == nil)) then
1383
- elseif (nil ~= _492_0) then
1384
- local clause = _492_0
1455
+ local _528_0 = clause_3f(bindings[i])
1456
+ if ((_528_0 == false) or (_528_0 == nil)) then
1457
+ elseif (nil ~= _528_0) then
1458
+ local clause = _528_0
1385
1459
  compiler.assert(((clause == "until") and not _until), ("unexpected iterator clause: " .. clause), ast)
1386
1460
  table.remove(bindings, i)
1387
1461
  _until = table.remove(bindings, i)
@@ -1391,8 +1465,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1391
1465
  end
1392
1466
  local function compile_until(_3fcondition, scope, chunk)
1393
1467
  if _3fcondition then
1394
- local _494_ = compiler.compile1(_3fcondition, scope, chunk, {nval = 1})
1395
- local condition_lua = _494_[1]
1468
+ local _530_ = compiler.compile1(_3fcondition, scope, chunk, {nval = 1})
1469
+ local condition_lua = _530_[1]
1396
1470
  return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(_3fcondition, "expression"))
1397
1471
  end
1398
1472
  end
@@ -1419,27 +1493,51 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1419
1493
  local sub_scope = compiler["make-scope"](scope)
1420
1494
  local binding, iter, _3funtil_condition = iterator_bindings(ast[2])
1421
1495
  local destructures = {}
1422
- local new_manglings = {}
1496
+ local deferred_scope_changes = {manglings = {}, symmeta = {}}
1423
1497
  utils.hook("pre-each", ast, sub_scope, binding, iter, _3funtil_condition)
1424
1498
  local function destructure_binding(v)
1425
1499
  if utils["sym?"](v) then
1426
- return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings)
1500
+ return compiler["declare-local"](v, sub_scope, ast, nil, deferred_scope_changes)
1427
1501
  else
1428
1502
  local raw = utils.sym(compiler.gensym(sub_scope))
1429
1503
  destructures[raw] = v
1430
- return compiler["declare-local"](raw, {}, sub_scope, ast)
1504
+ return compiler["declare-local"](raw, sub_scope, ast)
1505
+ end
1506
+ end
1507
+ local bind_vars = nil
1508
+ do
1509
+ local tbl_17_ = {}
1510
+ local i_18_ = #tbl_17_
1511
+ for _, b in ipairs(binding) do
1512
+ local val_19_ = destructure_binding(b)
1513
+ if (nil ~= val_19_) then
1514
+ i_18_ = (i_18_ + 1)
1515
+ tbl_17_[i_18_] = val_19_
1516
+ end
1431
1517
  end
1518
+ bind_vars = tbl_17_
1432
1519
  end
1433
- local bind_vars = utils.map(binding, destructure_binding)
1434
1520
  local vals = compiler.compile1(iter, scope, parent)
1435
- local val_names = utils.map(vals, tostring)
1521
+ local val_names = nil
1522
+ do
1523
+ local tbl_17_ = {}
1524
+ local i_18_ = #tbl_17_
1525
+ for _, v in ipairs(vals) do
1526
+ local val_19_ = tostring(v)
1527
+ if (nil ~= val_19_) then
1528
+ i_18_ = (i_18_ + 1)
1529
+ tbl_17_[i_18_] = val_19_
1530
+ end
1531
+ end
1532
+ val_names = tbl_17_
1533
+ end
1436
1534
  local chunk = {}
1437
1535
  compiler.assert(bind_vars[1], "expected binding and iterator", ast)
1438
1536
  compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast)
1439
1537
  for raw, args in utils.stablepairs(destructures) do
1440
1538
  compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"})
1441
1539
  end
1442
- compiler["apply-manglings"](sub_scope, new_manglings, ast)
1540
+ compiler["apply-deferred-scope-changes"](sub_scope, deferred_scope_changes, ast)
1443
1541
  compile_until(_3funtil_condition, sub_scope, chunk)
1444
1542
  compile_do(ast, sub_scope, chunk, 3)
1445
1543
  compiler.emit(parent, chunk, ast)
@@ -1481,9 +1579,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1481
1579
  compiler.assert((1 < #ranges), "expected range to include start and stop", ranges)
1482
1580
  utils.hook("pre-for", ast, sub_scope, binding_sym)
1483
1581
  for i = 1, math.min(#ranges, 3) do
1484
- range_args[i] = tostring(compiler.compile1(ranges[i], scope, parent, {nval = 1})[1])
1582
+ range_args[i] = str1(compiler.compile1(ranges[i], scope, parent, {nval = 1}))
1485
1583
  end
1486
- compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast)
1584
+ compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, sub_scope, ast), table.concat(range_args, ", ")), ast)
1487
1585
  compile_until(until_condition, sub_scope, chunk)
1488
1586
  compile_do(ast, sub_scope, chunk, 3)
1489
1587
  compiler.emit(parent, chunk, ast)
@@ -1491,13 +1589,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1491
1589
  end
1492
1590
  SPECIALS["for"] = for_2a
1493
1591
  doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true)
1592
+ local function method_special_type(ast)
1593
+ if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then
1594
+ return "native"
1595
+ elseif utils["sym?"](ast[2]) then
1596
+ return "nonnative"
1597
+ else
1598
+ return "binding"
1599
+ end
1600
+ end
1494
1601
  local function native_method_call(ast, _scope, _parent, target, args)
1495
- local _500_ = ast
1496
- local _ = _500_[1]
1497
- local _0 = _500_[2]
1498
- local method_string = _500_[3]
1602
+ local _539_ = ast
1603
+ local _ = _539_[1]
1604
+ local _0 = _539_[2]
1605
+ local method_string = _539_[3]
1499
1606
  local call_string = nil
1500
- if ((target.type == "literal") or (target.type == "varg") or (target.type == "expression")) then
1607
+ if ((target.type == "literal") or (target.type == "varg") or ((target.type == "expression") and not (target[1]):match("[%)%]]$") and not (target[1]):match("%.[%a_][%w_]*$"))) then
1501
1608
  call_string = "(%s):%s(%s)"
1502
1609
  else
1503
1610
  call_string = "%s:%s(%s)"
@@ -1505,45 +1612,55 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1505
1612
  return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement")
1506
1613
  end
1507
1614
  local function nonnative_method_call(ast, scope, parent, target, args)
1508
- local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1])
1615
+ local method_string = str1(compiler.compile1(ast[3], scope, parent, {nval = 1}))
1509
1616
  local args0 = {tostring(target), unpack(args)}
1510
1617
  return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement")
1511
1618
  end
1512
- local function double_eval_protected_method_call(ast, scope, parent, target, args)
1513
- local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1])
1514
- local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)"
1515
- table.insert(args, 1, method_string)
1516
- return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement")
1619
+ local function binding_method_call(ast, scope, parent, target, args)
1620
+ local method_string = str1(compiler.compile1(ast[3], scope, parent, {nval = 1}))
1621
+ local target_local = compiler.gensym(scope, "tgt")
1622
+ local args0 = {target_local, unpack(args)}
1623
+ compiler.emit(parent, string.format("local %s = %s", target_local, tostring(target)))
1624
+ return utils.expr(string.format("(%s)[%s](%s)", target_local, method_string, table.concat(args0, ", ")), "statement")
1517
1625
  end
1518
1626
  local function method_call(ast, scope, parent)
1519
1627
  compiler.assert((2 < #ast), "expected at least 2 arguments", ast)
1520
- local _502_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
1521
- local target = _502_[1]
1628
+ local _541_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
1629
+ local target = _541_[1]
1522
1630
  local args = {}
1523
1631
  for i = 4, #ast do
1524
1632
  local subexprs = nil
1525
- local _503_
1633
+ local _542_
1526
1634
  if (i ~= #ast) then
1527
- _503_ = 1
1635
+ _542_ = 1
1528
1636
  else
1529
- _503_ = nil
1637
+ _542_ = nil
1638
+ end
1639
+ subexprs = compiler.compile1(ast[i], scope, parent, {nval = _542_})
1640
+ local tbl_17_ = args
1641
+ local i_18_ = #tbl_17_
1642
+ for _, subexpr in ipairs(subexprs) do
1643
+ local val_19_ = tostring(subexpr)
1644
+ if (nil ~= val_19_) then
1645
+ i_18_ = (i_18_ + 1)
1646
+ tbl_17_[i_18_] = val_19_
1647
+ end
1530
1648
  end
1531
- subexprs = compiler.compile1(ast[i], scope, parent, {nval = _503_})
1532
- utils.map(subexprs, tostring, args)
1533
1649
  end
1534
- if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then
1650
+ local _545_0 = method_special_type(ast)
1651
+ if (_545_0 == "native") then
1535
1652
  return native_method_call(ast, scope, parent, target, args)
1536
- elseif (target.type == "sym") then
1653
+ elseif (_545_0 == "nonnative") then
1537
1654
  return nonnative_method_call(ast, scope, parent, target, args)
1538
- else
1539
- return double_eval_protected_method_call(ast, scope, parent, target, args)
1655
+ elseif (_545_0 == "binding") then
1656
+ return binding_method_call(ast, scope, parent, target, args)
1540
1657
  end
1541
1658
  end
1542
1659
  SPECIALS[":"] = method_call
1543
1660
  doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.")
1544
1661
  SPECIALS.comment = function(ast, _, parent)
1545
1662
  local c = nil
1546
- local _506_
1663
+ local _547_
1547
1664
  do
1548
1665
  local tbl_17_ = {}
1549
1666
  local i_18_ = #tbl_17_
@@ -1559,9 +1676,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1559
1676
  tbl_17_[i_18_] = val_19_
1560
1677
  end
1561
1678
  end
1562
- _506_ = tbl_17_
1679
+ _547_ = tbl_17_
1563
1680
  end
1564
- c = table.concat(_506_, " "):gsub("%]%]", "]\\]")
1681
+ c = table.concat(_547_, " "):gsub("%]%]", "]\\]")
1565
1682
  return compiler.emit(parent, ("--[[ " .. c .. " ]]"), ast)
1566
1683
  end
1567
1684
  doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true)
@@ -1582,18 +1699,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1582
1699
  compiler.assert((#ast == 2), "expected one argument", ast)
1583
1700
  local f_scope = nil
1584
1701
  do
1585
- local _511_0 = compiler["make-scope"](scope)
1586
- _511_0["vararg"] = false
1587
- _511_0["hashfn"] = true
1588
- f_scope = _511_0
1702
+ local _552_0 = compiler["make-scope"](scope)
1703
+ _552_0["vararg"] = false
1704
+ _552_0["hashfn"] = true
1705
+ f_scope = _552_0
1589
1706
  end
1590
1707
  local f_chunk = {}
1591
1708
  local name = compiler.gensym(scope)
1592
1709
  local symbol = utils.sym(name)
1593
1710
  local args = {}
1594
- compiler["declare-local"](symbol, {}, scope, ast)
1711
+ compiler["declare-local"](symbol, scope, ast)
1595
1712
  for i = 1, 9 do
1596
- args[i] = compiler["declare-local"](utils.sym(("$" .. i)), {}, f_scope, ast)
1713
+ args[i] = compiler["declare-local"](utils.sym(("$" .. i)), f_scope, ast)
1597
1714
  end
1598
1715
  local function walker(idx, node, _3fparent_node)
1599
1716
  if utils["sym?"](node, "$...") then
@@ -1626,67 +1743,156 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1626
1743
  return utils.expr(name, "sym")
1627
1744
  end
1628
1745
  doc_special("hashfn", {"..."}, "Function literal shorthand; args are either $... OR $1, $2, etc.")
1629
- local function maybe_short_circuit_protect(ast, i, name, _516_0)
1630
- local _517_ = _516_0
1631
- local mac = _517_["macros"]
1632
- local call = (utils["list?"](ast) and tostring(ast[1]))
1633
- if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then
1634
- return utils.list(utils.list(utils.sym("fn"), utils.sequence(utils.varg()), ast))
1746
+ local function comparator_special_type(ast)
1747
+ if (3 == #ast) then
1748
+ return "native"
1749
+ elseif utils["every?"]({unpack(ast, 3, (#ast - 1))}, utils["idempotent-expr?"]) then
1750
+ return "idempotent"
1635
1751
  else
1636
- return ast
1752
+ return "binding"
1637
1753
  end
1638
1754
  end
1639
- local function operator_special(name, zero_arity, unary_prefix, ast, scope, parent)
1640
- local len = #ast
1641
- local operands = {}
1642
- local padded_op = (" " .. name .. " ")
1643
- for i = 2, len do
1644
- local subast = maybe_short_circuit_protect(ast[i], i, name, scope)
1645
- local subexprs = compiler.compile1(subast, scope, parent)
1646
- if (i == len) then
1647
- utils.map(subexprs, tostring, operands)
1755
+ local function short_circuit_safe_3f(x, scope)
1756
+ if (("table" ~= type(x)) or utils["sym?"](x) or utils["varg?"](x)) then
1757
+ return true
1758
+ elseif utils["table?"](x) then
1759
+ local ok = true
1760
+ for k, v in pairs(x) do
1761
+ if not ok then break end
1762
+ ok = (short_circuit_safe_3f(v, scope) and short_circuit_safe_3f(k, scope))
1763
+ end
1764
+ return ok
1765
+ elseif utils["list?"](x) then
1766
+ if utils["sym?"](x[1]) then
1767
+ local _558_0 = str1(x)
1768
+ if ((_558_0 == "fn") or (_558_0 == "hashfn") or (_558_0 == "let") or (_558_0 == "local") or (_558_0 == "var") or (_558_0 == "set") or (_558_0 == "tset") or (_558_0 == "if") or (_558_0 == "each") or (_558_0 == "for") or (_558_0 == "while") or (_558_0 == "do") or (_558_0 == "lua") or (_558_0 == "global")) then
1769
+ return false
1770
+ elseif (((_558_0 == "<") or (_558_0 == ">") or (_558_0 == "<=") or (_558_0 == ">=") or (_558_0 == "=") or (_558_0 == "not=") or (_558_0 == "~=")) and (comparator_special_type(x) == "binding")) then
1771
+ return false
1772
+ else
1773
+ local function _559_()
1774
+ return (1 ~= x[2])
1775
+ end
1776
+ if ((_558_0 == "pick-values") and _559_()) then
1777
+ return false
1778
+ else
1779
+ local function _560_()
1780
+ local call = _558_0
1781
+ return scope.macros[call]
1782
+ end
1783
+ if ((nil ~= _558_0) and _560_()) then
1784
+ local call = _558_0
1785
+ return false
1786
+ else
1787
+ local function _561_()
1788
+ return (method_special_type(x) == "binding")
1789
+ end
1790
+ if ((_558_0 == ":") and _561_()) then
1791
+ return false
1792
+ else
1793
+ local _ = _558_0
1794
+ local ok = true
1795
+ for i = 2, #x do
1796
+ if not ok then break end
1797
+ ok = short_circuit_safe_3f(x[i], scope)
1798
+ end
1799
+ return ok
1800
+ end
1801
+ end
1802
+ end
1803
+ end
1648
1804
  else
1649
- table.insert(operands, tostring(subexprs[1]))
1805
+ local ok = true
1806
+ for _, v in ipairs(x) do
1807
+ if not ok then break end
1808
+ ok = short_circuit_safe_3f(v, scope)
1809
+ end
1810
+ return ok
1650
1811
  end
1651
1812
  end
1652
- local _520_0 = #operands
1653
- if (_520_0 == 0) then
1654
- local _521_
1655
- do
1656
- compiler.assert(zero_arity, "Expected more than 0 arguments", ast)
1657
- _521_ = zero_arity
1658
- end
1659
- return utils.expr(_521_, "literal")
1660
- elseif (_520_0 == 1) then
1661
- if utils["varg?"](ast[2]) then
1662
- return compiler.assert(false, "tried to use vararg with operator", ast)
1663
- elseif unary_prefix then
1813
+ end
1814
+ local function operator_special_result(ast, zero_arity, unary_prefix, padded_op, operands)
1815
+ local _565_0 = #operands
1816
+ if (_565_0 == 0) then
1817
+ if zero_arity then
1818
+ return utils.expr(zero_arity, "literal")
1819
+ else
1820
+ return compiler.assert(false, "Expected more than 0 arguments", ast)
1821
+ end
1822
+ elseif (_565_0 == 1) then
1823
+ if unary_prefix then
1664
1824
  return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")")
1665
1825
  else
1666
1826
  return operands[1]
1667
1827
  end
1668
1828
  else
1669
- local _ = _520_0
1829
+ local _ = _565_0
1670
1830
  return ("(" .. table.concat(operands, padded_op) .. ")")
1671
1831
  end
1672
1832
  end
1833
+ local function emit_short_circuit_if(ast, scope, parent, name, subast, accumulator, expr_string, setter)
1834
+ if (accumulator ~= expr_string) then
1835
+ compiler.emit(parent, string.format(setter, accumulator, expr_string), ast)
1836
+ end
1837
+ local function _570_()
1838
+ if (name == "and") then
1839
+ return accumulator
1840
+ else
1841
+ return ("not " .. accumulator)
1842
+ end
1843
+ end
1844
+ compiler.emit(parent, ("if %s then"):format(_570_()), subast)
1845
+ do
1846
+ local chunk = {}
1847
+ compiler.compile1(subast, scope, chunk, {nval = 1, target = accumulator})
1848
+ compiler.emit(parent, chunk)
1849
+ end
1850
+ return compiler.emit(parent, "end")
1851
+ end
1852
+ local function operator_special(name, zero_arity, unary_prefix, ast, scope, parent)
1853
+ compiler.assert(not ((#ast == 2) and utils["varg?"](ast[2])), "tried to use vararg with operator", ast)
1854
+ local padded_op = (" " .. name .. " ")
1855
+ local operands, accumulator = {}
1856
+ if utils["call-of?"](ast[#ast], "values") then
1857
+ utils.warn("multiple values in operators are deprecated", ast)
1858
+ end
1859
+ for subast in iter_args(ast) do
1860
+ if ((nil ~= next(operands)) and ((name == "or") or (name == "and")) and not short_circuit_safe_3f(subast, scope)) then
1861
+ local expr_string = table.concat(operands, padded_op)
1862
+ local setter = nil
1863
+ if accumulator then
1864
+ setter = "%s = %s"
1865
+ else
1866
+ setter = "local %s = %s"
1867
+ end
1868
+ if not accumulator then
1869
+ accumulator = compiler.gensym(scope, name)
1870
+ end
1871
+ emit_short_circuit_if(ast, scope, parent, name, subast, accumulator, expr_string, setter)
1872
+ operands = {accumulator}
1873
+ else
1874
+ table.insert(operands, str1(compiler.compile1(subast, scope, parent, {nval = 1})))
1875
+ end
1876
+ end
1877
+ return operator_special_result(ast, zero_arity, unary_prefix, padded_op, operands)
1878
+ end
1673
1879
  local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name)
1674
- local _525_
1880
+ local _576_
1675
1881
  do
1676
- local _524_0 = (_3flua_name or name)
1677
- local function _526_(...)
1678
- return operator_special(_524_0, zero_arity, unary_prefix, ...)
1882
+ local _575_0 = (_3flua_name or name)
1883
+ local function _577_(...)
1884
+ return operator_special(_575_0, zero_arity, unary_prefix, ...)
1679
1885
  end
1680
- _525_ = _526_
1886
+ _576_ = _577_
1681
1887
  end
1682
- SPECIALS[name] = _525_
1888
+ SPECIALS[name] = _576_
1683
1889
  return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.")
1684
1890
  end
1685
- define_arithmetic_special("+", "0")
1891
+ define_arithmetic_special("+", "0", "0")
1686
1892
  define_arithmetic_special("..", "''")
1687
1893
  define_arithmetic_special("^")
1688
1894
  define_arithmetic_special("-", nil, "")
1689
- define_arithmetic_special("*", "1")
1895
+ define_arithmetic_special("*", "1", "1")
1690
1896
  define_arithmetic_special("%")
1691
1897
  define_arithmetic_special("/", nil, "1")
1692
1898
  define_arithmetic_special("//", nil, "1")
@@ -1708,14 +1914,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1708
1914
  local prefixed_lib_name = ("bit." .. lib_name)
1709
1915
  for i = 2, len do
1710
1916
  local subexprs = nil
1711
- local _527_
1917
+ local _578_
1712
1918
  if (i ~= len) then
1713
- _527_ = 1
1919
+ _578_ = 1
1714
1920
  else
1715
- _527_ = nil
1921
+ _578_ = nil
1922
+ end
1923
+ subexprs = compiler.compile1(ast[i], scope, parent, {nval = _578_})
1924
+ local tbl_17_ = operands
1925
+ local i_18_ = #tbl_17_
1926
+ for _, s in ipairs(subexprs) do
1927
+ local val_19_ = tostring(s)
1928
+ if (nil ~= val_19_) then
1929
+ i_18_ = (i_18_ + 1)
1930
+ tbl_17_[i_18_] = val_19_
1931
+ end
1716
1932
  end
1717
- subexprs = compiler.compile1(ast[i], scope, parent, {nval = _527_})
1718
- utils.map(subexprs, tostring, operands)
1719
1933
  end
1720
1934
  if (#operands == 1) then
1721
1935
  if utils.root.options.useBitLib then
@@ -1733,10 +1947,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1733
1947
  end
1734
1948
  end
1735
1949
  local function define_bitop_special(name, zero_arity, unary_prefix, native)
1736
- local function _533_(...)
1950
+ local function _585_(...)
1737
1951
  return bitop_special(native, name, zero_arity, unary_prefix, ...)
1738
1952
  end
1739
- SPECIALS[name] = _533_
1953
+ SPECIALS[name] = _585_
1740
1954
  return nil
1741
1955
  end
1742
1956
  define_bitop_special("lshift", nil, "1", "<<")
@@ -1751,8 +1965,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1751
1965
  doc_special("bxor", {"x1", "x2", "..."}, "Bitwise XOR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
1752
1966
  SPECIALS.bnot = function(ast, scope, parent)
1753
1967
  compiler.assert((#ast == 2), "expected one argument", ast)
1754
- local _534_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
1755
- local value = _534_[1]
1968
+ local _586_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
1969
+ local value = _586_[1]
1756
1970
  if utils.root.options.useBitLib then
1757
1971
  return ("bit.bnot(" .. tostring(value) .. ")")
1758
1972
  else
@@ -1761,15 +1975,15 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1761
1975
  end
1762
1976
  doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
1763
1977
  doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.")
1764
- local function native_comparator(op, _536_0, scope, parent)
1765
- local _537_ = _536_0
1766
- local _ = _537_[1]
1767
- local lhs_ast = _537_[2]
1768
- local rhs_ast = _537_[3]
1769
- local _538_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1})
1770
- local lhs = _538_[1]
1771
- local _539_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1})
1772
- local rhs = _539_[1]
1978
+ local function native_comparator(op, _588_0, scope, parent)
1979
+ local _589_ = _588_0
1980
+ local _ = _589_[1]
1981
+ local lhs_ast = _589_[2]
1982
+ local rhs_ast = _589_[3]
1983
+ local _590_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1})
1984
+ local lhs = _590_[1]
1985
+ local _591_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1})
1986
+ local rhs = _591_[1]
1773
1987
  return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs))
1774
1988
  end
1775
1989
  local function idempotent_comparator(op, chain_op, ast, scope, parent)
@@ -1778,7 +1992,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1778
1992
  local tbl_17_ = {}
1779
1993
  local i_18_ = #tbl_17_
1780
1994
  for i = 2, #ast do
1781
- local val_19_ = tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1])
1995
+ local val_19_ = str1(compiler.compile1(ast[i], scope, parent, {nval = 1}))
1782
1996
  if (nil ~= val_19_) then
1783
1997
  i_18_ = (i_18_ + 1)
1784
1998
  tbl_17_[i_18_] = val_19_
@@ -1802,39 +2016,53 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1802
2016
  local chain = string.format(" %s ", (chain_op or "and"))
1803
2017
  return ("(" .. table.concat(comparisons, chain) .. ")")
1804
2018
  end
1805
- local function double_eval_protected_comparator(op, chain_op, ast, scope, parent)
1806
- local arglist = {}
1807
- local comparisons = {}
2019
+ local function binding_comparator(op, chain_op, ast, scope, parent)
2020
+ local binding_left = {}
2021
+ local binding_right = {}
1808
2022
  local vals = {}
1809
2023
  local chain = string.format(" %s ", (chain_op or "and"))
1810
2024
  for i = 2, #ast do
1811
- table.insert(arglist, tostring(compiler.gensym(scope)))
1812
- table.insert(vals, tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1]))
2025
+ local compiled = str1(compiler.compile1(ast[i], scope, parent, {nval = 1}))
2026
+ if (utils["idempotent-expr?"](ast[i]) or (i == 2) or (i == #ast)) then
2027
+ table.insert(vals, compiled)
2028
+ else
2029
+ local my_sym = compiler.gensym(scope)
2030
+ table.insert(binding_left, my_sym)
2031
+ table.insert(binding_right, compiled)
2032
+ table.insert(vals, my_sym)
2033
+ end
1813
2034
  end
2035
+ compiler.emit(parent, string.format("local %s = %s", table.concat(binding_left, ", "), table.concat(binding_right, ", "), ast))
2036
+ local _595_
1814
2037
  do
1815
- local tbl_17_ = comparisons
2038
+ local tbl_17_ = {}
1816
2039
  local i_18_ = #tbl_17_
1817
- for i = 1, (#arglist - 1) do
1818
- local val_19_ = string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)])
2040
+ for i = 1, (#vals - 1) do
2041
+ local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)])
1819
2042
  if (nil ~= val_19_) then
1820
2043
  i_18_ = (i_18_ + 1)
1821
2044
  tbl_17_[i_18_] = val_19_
1822
2045
  end
1823
2046
  end
2047
+ _595_ = tbl_17_
1824
2048
  end
1825
- return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ","))
2049
+ return ("(" .. table.concat(_595_, chain) .. ")")
1826
2050
  end
1827
2051
  local function define_comparator_special(name, _3flua_op, _3fchain_op)
1828
2052
  do
1829
2053
  local op = (_3flua_op or name)
1830
2054
  local function opfn(ast, scope, parent)
1831
2055
  compiler.assert((2 < #ast), "expected at least two arguments", ast)
1832
- if (3 == #ast) then
2056
+ local _597_0 = comparator_special_type(ast)
2057
+ if (_597_0 == "native") then
1833
2058
  return native_comparator(op, ast, scope, parent)
1834
- elseif utils["every?"]({unpack(ast, 2)}, utils["idempotent-expr?"]) then
2059
+ elseif (_597_0 == "idempotent") then
1835
2060
  return idempotent_comparator(op, _3fchain_op, ast, scope, parent)
2061
+ elseif (_597_0 == "binding") then
2062
+ return binding_comparator(op, _3fchain_op, ast, scope, parent)
1836
2063
  else
1837
- return double_eval_protected_comparator(op, _3fchain_op, ast, scope, parent)
2064
+ local _ = _597_0
2065
+ return error("internal compiler error. please report this to the fennel devs.")
1838
2066
  end
1839
2067
  end
1840
2068
  SPECIALS[name] = opfn
@@ -1851,7 +2079,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1851
2079
  local function opfn(ast, scope, parent)
1852
2080
  compiler.assert((#ast == 2), "expected one argument", ast)
1853
2081
  local tail = compiler.compile1(ast[2], scope, parent, {nval = 1})
1854
- return ((_3frealop or op) .. tostring(tail[1]))
2082
+ return ((_3frealop or op) .. str1(tail))
1855
2083
  end
1856
2084
  SPECIALS[op] = opfn
1857
2085
  return nil
@@ -1882,21 +2110,21 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1882
2110
  end
1883
2111
  local safe_require = nil
1884
2112
  local function safe_compiler_env()
1885
- local _546_
2113
+ local _601_
1886
2114
  do
1887
- local _545_0 = rawget(_G, "utf8")
1888
- if (nil ~= _545_0) then
1889
- _546_ = utils.copy(_545_0)
2115
+ local _600_0 = rawget(_G, "utf8")
2116
+ if (nil ~= _600_0) then
2117
+ _601_ = utils.copy(_600_0)
1890
2118
  else
1891
- _546_ = _545_0
2119
+ _601_ = _600_0
1892
2120
  end
1893
2121
  end
1894
- return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, require = safe_require, select = select, setmetatable = setmetatable, string = utils.copy(string), table = utils.copy(table), tonumber = tonumber, tostring = tostring, type = type, utf8 = _546_, xpcall = xpcall}
2122
+ return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, require = safe_require, select = select, setmetatable = setmetatable, string = utils.copy(string), table = utils.copy(table), tonumber = tonumber, tostring = tostring, type = type, utf8 = _601_, xpcall = xpcall}
1895
2123
  end
1896
2124
  local function combined_mt_pairs(env)
1897
2125
  local combined = {}
1898
- local _548_ = getmetatable(env)
1899
- local __index = _548_["__index"]
2126
+ local _603_ = getmetatable(env)
2127
+ local __index = _603_["__index"]
1900
2128
  if ("table" == type(__index)) then
1901
2129
  for k, v in pairs(__index) do
1902
2130
  combined[k] = v
@@ -1910,40 +2138,40 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1910
2138
  local function make_compiler_env(ast, scope, parent, _3fopts)
1911
2139
  local provided = nil
1912
2140
  do
1913
- local _550_0 = (_3fopts or utils.root.options)
1914
- if ((_G.type(_550_0) == "table") and (_550_0["compiler-env"] == "strict")) then
2141
+ local _605_0 = (_3fopts or utils.root.options)
2142
+ if ((_G.type(_605_0) == "table") and (_605_0["compiler-env"] == "strict")) then
1915
2143
  provided = safe_compiler_env()
1916
- elseif ((_G.type(_550_0) == "table") and (nil ~= _550_0.compilerEnv)) then
1917
- local compilerEnv = _550_0.compilerEnv
2144
+ elseif ((_G.type(_605_0) == "table") and (nil ~= _605_0.compilerEnv)) then
2145
+ local compilerEnv = _605_0.compilerEnv
1918
2146
  provided = compilerEnv
1919
- elseif ((_G.type(_550_0) == "table") and (nil ~= _550_0["compiler-env"])) then
1920
- local compiler_env = _550_0["compiler-env"]
2147
+ elseif ((_G.type(_605_0) == "table") and (nil ~= _605_0["compiler-env"])) then
2148
+ local compiler_env = _605_0["compiler-env"]
1921
2149
  provided = compiler_env
1922
2150
  else
1923
- local _ = _550_0
2151
+ local _ = _605_0
1924
2152
  provided = safe_compiler_env()
1925
2153
  end
1926
2154
  end
1927
2155
  local env = nil
1928
- local function _552_()
2156
+ local function _607_()
1929
2157
  return compiler.scopes.macro
1930
2158
  end
1931
- local function _553_(symbol)
2159
+ local function _608_(symbol)
1932
2160
  compiler.assert(compiler.scopes.macro, "must call from macro", ast)
1933
2161
  return compiler.scopes.macro.manglings[tostring(symbol)]
1934
2162
  end
1935
- local function _554_(base)
2163
+ local function _609_(base)
1936
2164
  return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base))
1937
2165
  end
1938
- local function _555_(form)
2166
+ local function _610_(form)
1939
2167
  compiler.assert(compiler.scopes.macro, "must call from macro", ast)
1940
2168
  return compiler.macroexpand(form, compiler.scopes.macro)
1941
2169
  end
1942
- env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["fennel-module-name"] = fennel_module_name, ["get-scope"] = _552_, ["in-scope?"] = _553_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), comment = utils.comment, gensym = _554_, list = utils.list, macroexpand = _555_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view}
2170
+ env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["fennel-module-name"] = fennel_module_name, ["get-scope"] = _607_, ["in-scope?"] = _608_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), comment = utils.comment, gensym = _609_, list = utils.list, macroexpand = _610_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view}
1943
2171
  env._G = env
1944
2172
  return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs})
1945
2173
  end
1946
- local function _556_(...)
2174
+ local function _611_(...)
1947
2175
  local tbl_17_ = {}
1948
2176
  local i_18_ = #tbl_17_
1949
2177
  for c in string.gmatch((package.config or ""), "([^\n]+)") do
@@ -1955,10 +2183,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1955
2183
  end
1956
2184
  return tbl_17_
1957
2185
  end
1958
- local _558_ = _556_(...)
1959
- local dirsep = _558_[1]
1960
- local pathsep = _558_[2]
1961
- local pathmark = _558_[3]
2186
+ local _613_ = _611_(...)
2187
+ local dirsep = _613_[1]
2188
+ local pathsep = _613_[2]
2189
+ local pathmark = _613_[3]
1962
2190
  local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or "?"), pathsep = (pathsep or ";")}
1963
2191
  local function escapepat(str)
1964
2192
  return string.gsub(str, "[^%w]", "%%%1")
@@ -1971,36 +2199,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
1971
2199
  local function try_path(path)
1972
2200
  local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module)
1973
2201
  local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename)
1974
- local _559_0 = (io.open(filename) or io.open(filename2))
1975
- if (nil ~= _559_0) then
1976
- local file = _559_0
2202
+ local _614_0 = (io.open(filename) or io.open(filename2))
2203
+ if (nil ~= _614_0) then
2204
+ local file = _614_0
1977
2205
  file:close()
1978
2206
  return filename
1979
2207
  else
1980
- local _ = _559_0
2208
+ local _ = _614_0
1981
2209
  return nil, ("no file '" .. filename .. "'")
1982
2210
  end
1983
2211
  end
1984
2212
  local function find_in_path(start, _3ftried_paths)
1985
- local _561_0 = fullpath:match(pattern, start)
1986
- if (nil ~= _561_0) then
1987
- local path = _561_0
1988
- local _562_0, _563_0 = try_path(path)
1989
- if (nil ~= _562_0) then
1990
- local filename = _562_0
2213
+ local _616_0 = fullpath:match(pattern, start)
2214
+ if (nil ~= _616_0) then
2215
+ local path = _616_0
2216
+ local _617_0, _618_0 = try_path(path)
2217
+ if (nil ~= _617_0) then
2218
+ local filename = _617_0
1991
2219
  return filename
1992
- elseif ((_562_0 == nil) and (nil ~= _563_0)) then
1993
- local error = _563_0
1994
- local function _565_()
1995
- local _564_0 = (_3ftried_paths or {})
1996
- table.insert(_564_0, error)
1997
- return _564_0
2220
+ elseif ((_617_0 == nil) and (nil ~= _618_0)) then
2221
+ local error = _618_0
2222
+ local function _620_()
2223
+ local _619_0 = (_3ftried_paths or {})
2224
+ table.insert(_619_0, error)
2225
+ return _619_0
1998
2226
  end
1999
- return find_in_path((start + #path + 1), _565_())
2227
+ return find_in_path((start + #path + 1), _620_())
2000
2228
  end
2001
2229
  else
2002
- local _ = _561_0
2003
- local function _567_()
2230
+ local _ = _616_0
2231
+ local function _622_()
2004
2232
  local tried_paths = table.concat((_3ftried_paths or {}), "\n\9")
2005
2233
  if (_VERSION < "Lua 5.4") then
2006
2234
  return ("\n\9" .. tried_paths)
@@ -2008,31 +2236,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2008
2236
  return tried_paths
2009
2237
  end
2010
2238
  end
2011
- return nil, _567_()
2239
+ return nil, _622_()
2012
2240
  end
2013
2241
  end
2014
2242
  return find_in_path(1)
2015
2243
  end
2016
2244
  local function make_searcher(_3foptions)
2017
- local function _570_(module_name)
2245
+ local function _625_(module_name)
2018
2246
  local opts = utils.copy(utils.root.options)
2019
2247
  for k, v in pairs((_3foptions or {})) do
2020
2248
  opts[k] = v
2021
2249
  end
2022
2250
  opts["module-name"] = module_name
2023
- local _571_0, _572_0 = search_module(module_name)
2024
- if (nil ~= _571_0) then
2025
- local filename = _571_0
2026
- local function _573_(...)
2251
+ local _626_0, _627_0 = search_module(module_name)
2252
+ if (nil ~= _626_0) then
2253
+ local filename = _626_0
2254
+ local function _628_(...)
2027
2255
  return utils["fennel-module"].dofile(filename, opts, ...)
2028
2256
  end
2029
- return _573_, filename
2030
- elseif ((_571_0 == nil) and (nil ~= _572_0)) then
2031
- local error = _572_0
2257
+ return _628_, filename
2258
+ elseif ((_626_0 == nil) and (nil ~= _627_0)) then
2259
+ local error = _627_0
2032
2260
  return error
2033
2261
  end
2034
2262
  end
2035
- return _570_
2263
+ return _625_
2036
2264
  end
2037
2265
  local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...)
2038
2266
  local searchers = (package.loaders or package.searchers or {})
@@ -2044,35 +2272,35 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2044
2272
  local function fennel_macro_searcher(module_name)
2045
2273
  local opts = nil
2046
2274
  do
2047
- local _575_0 = utils.copy(utils.root.options)
2048
- _575_0["module-name"] = module_name
2049
- _575_0["env"] = "_COMPILER"
2050
- _575_0["requireAsInclude"] = false
2051
- _575_0["allowedGlobals"] = nil
2052
- opts = _575_0
2053
- end
2054
- local _576_0 = search_module(module_name, utils["fennel-module"]["macro-path"])
2055
- if (nil ~= _576_0) then
2056
- local filename = _576_0
2057
- local _577_
2275
+ local _630_0 = utils.copy(utils.root.options)
2276
+ _630_0["module-name"] = module_name
2277
+ _630_0["env"] = "_COMPILER"
2278
+ _630_0["requireAsInclude"] = false
2279
+ _630_0["allowedGlobals"] = nil
2280
+ opts = _630_0
2281
+ end
2282
+ local _631_0 = search_module(module_name, utils["fennel-module"]["macro-path"])
2283
+ if (nil ~= _631_0) then
2284
+ local filename = _631_0
2285
+ local _632_
2058
2286
  if (opts["compiler-env"] == _G) then
2059
- local function _578_(...)
2287
+ local function _633_(...)
2060
2288
  return dofile_with_searcher(fennel_macro_searcher, filename, opts, ...)
2061
2289
  end
2062
- _577_ = _578_
2290
+ _632_ = _633_
2063
2291
  else
2064
- local function _579_(...)
2292
+ local function _634_(...)
2065
2293
  return utils["fennel-module"].dofile(filename, opts, ...)
2066
2294
  end
2067
- _577_ = _579_
2295
+ _632_ = _634_
2068
2296
  end
2069
- return _577_, filename
2297
+ return _632_, filename
2070
2298
  end
2071
2299
  end
2072
2300
  local function lua_macro_searcher(module_name)
2073
- local _582_0 = search_module(module_name, package.path)
2074
- if (nil ~= _582_0) then
2075
- local filename = _582_0
2301
+ local _637_0 = search_module(module_name, package.path)
2302
+ if (nil ~= _637_0) then
2303
+ local filename = _637_0
2076
2304
  local code = nil
2077
2305
  do
2078
2306
  local f = io.open(filename)
@@ -2084,10 +2312,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2084
2312
  return error(..., 0)
2085
2313
  end
2086
2314
  end
2087
- local function _584_()
2315
+ local function _639_()
2088
2316
  return assert(f:read("*a"))
2089
2317
  end
2090
- code = close_handlers_10_(_G.xpcall(_584_, (package.loaded.fennel or debug).traceback))
2318
+ code = close_handlers_10_(_G.xpcall(_639_, (package.loaded.fennel or debug).traceback))
2091
2319
  end
2092
2320
  local chunk = load_code(code, make_compiler_env(), filename)
2093
2321
  return chunk, filename
@@ -2095,38 +2323,38 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2095
2323
  end
2096
2324
  local macro_searchers = {fennel_macro_searcher, lua_macro_searcher}
2097
2325
  local function search_macro_module(modname, n)
2098
- local _586_0 = macro_searchers[n]
2099
- if (nil ~= _586_0) then
2100
- local f = _586_0
2101
- local _587_0, _588_0 = f(modname)
2102
- if ((nil ~= _587_0) and true) then
2103
- local loader = _587_0
2104
- local _3ffilename = _588_0
2326
+ local _641_0 = macro_searchers[n]
2327
+ if (nil ~= _641_0) then
2328
+ local f = _641_0
2329
+ local _642_0, _643_0 = f(modname)
2330
+ if ((nil ~= _642_0) and true) then
2331
+ local loader = _642_0
2332
+ local _3ffilename = _643_0
2105
2333
  return loader, _3ffilename
2106
2334
  else
2107
- local _ = _587_0
2335
+ local _ = _642_0
2108
2336
  return search_macro_module(modname, (n + 1))
2109
2337
  end
2110
2338
  end
2111
2339
  end
2112
2340
  local function sandbox_fennel_module(modname)
2113
2341
  if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then
2114
- local function _591_(_, ...)
2342
+ local function _646_(_, ...)
2115
2343
  return (compiler.metadata):setall(...)
2116
2344
  end
2117
- return {metadata = {setall = _591_}, view = view}
2345
+ return {metadata = {setall = _646_}, view = view}
2118
2346
  end
2119
2347
  end
2120
- local function _593_(modname)
2121
- local function _594_()
2348
+ local function _648_(modname)
2349
+ local function _649_()
2122
2350
  local loader, filename = search_macro_module(modname, 1)
2123
2351
  compiler.assert(loader, (modname .. " module not found."))
2124
2352
  macro_loaded[modname] = loader(modname, filename)
2125
2353
  return macro_loaded[modname]
2126
2354
  end
2127
- return (macro_loaded[modname] or sandbox_fennel_module(modname) or _594_())
2355
+ return (macro_loaded[modname] or sandbox_fennel_module(modname) or _649_())
2128
2356
  end
2129
- safe_require = _593_
2357
+ safe_require = _648_
2130
2358
  local function add_macros(macros_2a, ast, scope)
2131
2359
  compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast)
2132
2360
  for k, v in pairs(macros_2a) do
@@ -2136,10 +2364,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2136
2364
  end
2137
2365
  return nil
2138
2366
  end
2139
- local function resolve_module_name(_595_0, _scope, _parent, opts)
2140
- local _596_ = _595_0
2141
- local second = _596_[2]
2142
- local filename = _596_["filename"]
2367
+ local function resolve_module_name(_650_0, _scope, _parent, opts)
2368
+ local _651_ = _650_0
2369
+ local second = _651_[2]
2370
+ local filename = _651_["filename"]
2143
2371
  local filename0 = (filename or (utils["table?"](second) and second.filename))
2144
2372
  local module_name = utils.root.options["module-name"]
2145
2373
  local modexpr = compiler.compile(second, opts)
@@ -2155,13 +2383,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2155
2383
  compiler.assert(loader, (modname .. " module not found."), ast)
2156
2384
  macro_loaded[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast))
2157
2385
  end
2158
- if ("import-macros" == tostring(ast[1])) then
2386
+ if ("import-macros" == str1(ast)) then
2159
2387
  return macro_loaded[modname]
2160
2388
  else
2161
2389
  return add_macros(macro_loaded[modname], ast, scope)
2162
2390
  end
2163
2391
  end
2164
- doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.")
2392
+ doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nDeprecated.")
2165
2393
  local function emit_included_fennel(src, path, opts, sub_chunk)
2166
2394
  local subscope = compiler["make-scope"](utils.root.scope.parent)
2167
2395
  local forms = {}
@@ -2196,10 +2424,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2196
2424
  return error(..., 0)
2197
2425
  end
2198
2426
  end
2199
- local function _602_()
2427
+ local function _657_()
2200
2428
  return assert(f:read("*all")):gsub("[\13\n]*$", "")
2201
2429
  end
2202
- src = close_handlers_10_(_G.xpcall(_602_, (package.loaded.fennel or debug).traceback))
2430
+ src = close_handlers_10_(_G.xpcall(_657_, (package.loaded.fennel or debug).traceback))
2203
2431
  end
2204
2432
  local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement")
2205
2433
  local target = ("package.preload[%q]"):format(mod)
@@ -2229,12 +2457,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2229
2457
  compiler.assert((#ast == 2), "expected one argument", ast)
2230
2458
  local modexpr = nil
2231
2459
  do
2232
- local _605_0, _606_0 = pcall(resolve_module_name, ast, scope, parent, opts)
2233
- if ((_605_0 == true) and (nil ~= _606_0)) then
2234
- local modname = _606_0
2460
+ local _660_0, _661_0 = pcall(resolve_module_name, ast, scope, parent, opts)
2461
+ if ((_660_0 == true) and (nil ~= _661_0)) then
2462
+ local modname = _661_0
2235
2463
  modexpr = utils.expr(string.format("%q", modname), "literal")
2236
2464
  else
2237
- local _ = _605_0
2465
+ local _ = _660_0
2238
2466
  modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
2239
2467
  end
2240
2468
  end
@@ -2251,13 +2479,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2251
2479
  utils.root.options["module-name"] = mod
2252
2480
  _ = nil
2253
2481
  local res = nil
2254
- local function _610_()
2255
- local _609_0 = search_module(mod)
2256
- if (nil ~= _609_0) then
2257
- local fennel_path = _609_0
2482
+ local function _665_()
2483
+ local _664_0 = search_module(mod)
2484
+ if (nil ~= _664_0) then
2485
+ local fennel_path = _664_0
2258
2486
  return include_path(ast, opts, fennel_path, mod, true)
2259
2487
  else
2260
- local _0 = _609_0
2488
+ local _0 = _664_0
2261
2489
  local lua_path = search_module(mod, package.path)
2262
2490
  if lua_path then
2263
2491
  return include_path(ast, opts, lua_path, mod, false)
@@ -2268,7 +2496,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2268
2496
  end
2269
2497
  end
2270
2498
  end
2271
- res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _610_())
2499
+ res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _665_())
2272
2500
  utils.root.options["module-name"] = oldmod
2273
2501
  return res
2274
2502
  end
@@ -2297,6 +2525,39 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
2297
2525
  return compiler.compile1(call, scope, parent, opts)
2298
2526
  end
2299
2527
  doc_special("tail!", {"body"}, "Assert that the body being called is in tail position.")
2528
+ SPECIALS["pick-values"] = function(ast, scope, parent)
2529
+ local n = ast[2]
2530
+ local vals = utils.list(utils.sym("values"), unpack(ast, 3))
2531
+ compiler.assert((("number" == type(n)) and (0 <= n) and (n == math.floor(n))), ("Expected n to be an integer >= 0, got " .. tostring(n)))
2532
+ if (1 == n) then
2533
+ local _669_ = compiler.compile1(vals, scope, parent, {nval = 1})
2534
+ local _670_ = _669_[1]
2535
+ local expr = _670_[1]
2536
+ return {("(" .. expr .. ")")}
2537
+ elseif (0 == n) then
2538
+ for i = 3, #ast do
2539
+ compiler["keep-side-effects"](compiler.compile1(ast[i], scope, parent, {nval = 0}), parent, nil, ast[i])
2540
+ end
2541
+ return {}
2542
+ else
2543
+ local syms = nil
2544
+ do
2545
+ local tbl_17_ = utils.list()
2546
+ local i_18_ = #tbl_17_
2547
+ for _ = 1, n do
2548
+ local val_19_ = utils.sym(compiler.gensym(scope, "pv"))
2549
+ if (nil ~= val_19_) then
2550
+ i_18_ = (i_18_ + 1)
2551
+ tbl_17_[i_18_] = val_19_
2552
+ end
2553
+ end
2554
+ syms = tbl_17_
2555
+ end
2556
+ compiler.destructure(syms, vals, ast, scope, parent, {declaration = true, nomulti = true, noundef = true, symtype = "pv"})
2557
+ return syms
2558
+ end
2559
+ end
2560
+ doc_special("pick-values", {"n", "..."}, "Evaluate to exactly n values.\n\nFor example,\n (pick-values 2 ...)\nexpands to\n (let [(_0_ _1_) ...]\n (values _0_ _1_))")
2300
2561
  SPECIALS["eval-compiler"] = function(ast, scope, parent)
2301
2562
  local old_first = ast[1]
2302
2563
  ast[1] = utils.sym("do")
@@ -2319,13 +2580,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2319
2580
  local scopes = {compiler = nil, global = nil, macro = nil}
2320
2581
  local function make_scope(_3fparent)
2321
2582
  local parent = (_3fparent or scopes.global)
2322
- local _264_
2583
+ local _265_
2323
2584
  if parent then
2324
- _264_ = ((parent.depth or 0) + 1)
2585
+ _265_ = ((parent.depth or 0) + 1)
2325
2586
  else
2326
- _264_ = 0
2587
+ _265_ = 0
2327
2588
  end
2328
- return {["gensym-base"] = setmetatable({}, {__index = (parent and parent["gensym-base"])}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _264_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)}
2589
+ return {["gensym-base"] = setmetatable({}, {__index = (parent and parent["gensym-base"])}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _265_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)}
2329
2590
  end
2330
2591
  local function assert_msg(ast, msg)
2331
2592
  local ast_tbl = nil
@@ -2343,10 +2604,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2343
2604
  end
2344
2605
  local function assert_compile(condition, msg, ast, _3ffallback_ast)
2345
2606
  if not condition then
2346
- local _267_ = (utils.root.options or {})
2347
- local error_pinpoint = _267_["error-pinpoint"]
2348
- local source = _267_["source"]
2349
- local unfriendly = _267_["unfriendly"]
2607
+ local _268_ = (utils.root.options or {})
2608
+ local error_pinpoint = _268_["error-pinpoint"]
2609
+ local source = _268_["source"]
2610
+ local unfriendly = _268_["unfriendly"]
2350
2611
  local ast0 = nil
2351
2612
  if next(utils["ast-source"](ast)) then
2352
2613
  ast0 = ast
@@ -2368,35 +2629,34 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2368
2629
  scopes.global.vararg = true
2369
2630
  scopes.compiler = make_scope(scopes.global)
2370
2631
  scopes.macro = scopes.global
2371
- local serialize_subst = {["\11"] = "\\v", ["\12"] = "\\f", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n"}
2372
2632
  local function serialize_string(str)
2373
- local function _272_(_241)
2633
+ local function _273_(_241)
2374
2634
  return ("\\" .. _241:byte())
2375
2635
  end
2376
- return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _272_)
2636
+ return string.gsub(string.gsub(string.gsub(string.format("%q", str), "\\\n", "\\n"), "\\9", "\\t"), "[\128-\255]", _273_)
2377
2637
  end
2378
2638
  local function global_mangling(str)
2379
2639
  if utils["valid-lua-identifier?"](str) then
2380
2640
  return str
2381
2641
  else
2382
- local function _273_(_241)
2642
+ local function _274_(_241)
2383
2643
  return string.format("_%02x", _241:byte())
2384
2644
  end
2385
- return ("__fnl_global__" .. str:gsub("[^%w]", _273_))
2645
+ return ("__fnl_global__" .. str:gsub("[^%w]", _274_))
2386
2646
  end
2387
2647
  end
2388
2648
  local function global_unmangling(identifier)
2389
- local _275_0 = string.match(identifier, "^__fnl_global__(.*)$")
2390
- if (nil ~= _275_0) then
2391
- local rest = _275_0
2392
- local _276_0 = nil
2393
- local function _277_(_241)
2649
+ local _276_0 = string.match(identifier, "^__fnl_global__(.*)$")
2650
+ if (nil ~= _276_0) then
2651
+ local rest = _276_0
2652
+ local _277_0 = nil
2653
+ local function _278_(_241)
2394
2654
  return string.char(tonumber(_241:sub(2), 16))
2395
2655
  end
2396
- _276_0 = string.gsub(rest, "_[%da-f][%da-f]", _277_)
2397
- return _276_0
2656
+ _277_0 = string.gsub(rest, "_[%da-f][%da-f]", _278_)
2657
+ return _277_0
2398
2658
  else
2399
- local _ = _275_0
2659
+ local _ = _276_0
2400
2660
  return identifier
2401
2661
  end
2402
2662
  end
@@ -2411,32 +2671,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2411
2671
  return mangling
2412
2672
  end
2413
2673
  end
2414
- local function local_mangling(str, scope, ast, _3ftemp_manglings)
2415
- assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast)
2416
- local raw = nil
2417
- if (utils["lua-keywords"][str] or str:match("^%d")) then
2418
- raw = ("_" .. str)
2419
- else
2420
- raw = str
2421
- end
2422
- local mangling = nil
2423
- local function _281_(_241)
2424
- return string.format("_%02x", _241:byte())
2425
- end
2426
- mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _281_)
2427
- local unique = unique_mangling(mangling, mangling, scope, 0)
2428
- scope.unmanglings[unique] = (scope["gensym-base"][str] or str)
2429
- do
2430
- local manglings = (_3ftemp_manglings or scope.manglings)
2431
- manglings[str] = unique
2432
- end
2433
- return unique
2434
- end
2435
- local function apply_manglings(scope, new_manglings, ast)
2436
- for raw, mangled in pairs(new_manglings) do
2674
+ local function apply_deferred_scope_changes(scope, deferred_scope_changes, ast)
2675
+ for raw, mangled in pairs(deferred_scope_changes.manglings) do
2437
2676
  assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast)
2438
2677
  scope.manglings[raw] = mangled
2439
2678
  end
2679
+ for raw, symmeta in pairs(deferred_scope_changes.symmeta) do
2680
+ scope.symmeta[raw] = symmeta
2681
+ end
2440
2682
  return nil
2441
2683
  end
2442
2684
  local function combine_parts(parts, scope)
@@ -2454,14 +2696,18 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2454
2696
  end
2455
2697
  return ret
2456
2698
  end
2457
- local function next_append()
2458
- utils.root.scope["gensym-append"] = ((utils.root.scope["gensym-append"] or 0) + 1)
2459
- return ("_" .. utils.root.scope["gensym-append"] .. "_")
2699
+ local function root_scope(scope)
2700
+ return ((utils.root and utils.root.scope) or (scope.parent and root_scope(scope.parent)) or scope)
2701
+ end
2702
+ local function next_append(root_scope_2a)
2703
+ root_scope_2a["gensym-append"] = ((root_scope_2a["gensym-append"] or 0) + 1)
2704
+ return ("_" .. root_scope_2a["gensym-append"] .. "_")
2460
2705
  end
2461
2706
  local function gensym(scope, _3fbase, _3fsuffix)
2462
- local mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or ""))
2707
+ local root_scope_2a = root_scope(scope)
2708
+ local mangling = ((_3fbase or "") .. next_append(root_scope_2a) .. (_3fsuffix or ""))
2463
2709
  while scope.unmanglings[mangling] do
2464
- mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or ""))
2710
+ mangling = ((_3fbase or "") .. next_append(root_scope_2a) .. (_3fsuffix or ""))
2465
2711
  end
2466
2712
  if (_3fbase and (0 < #_3fbase)) then
2467
2713
  scope["gensym-base"][mangling] = _3fbase
@@ -2478,41 +2724,58 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2478
2724
  return table.concat(parts, ".")
2479
2725
  end
2480
2726
  local function autogensym(base, scope)
2481
- local _285_0 = utils["multi-sym?"](base)
2482
- if (nil ~= _285_0) then
2483
- local parts = _285_0
2727
+ local _284_0 = utils["multi-sym?"](base)
2728
+ if (nil ~= _284_0) then
2729
+ local parts = _284_0
2484
2730
  return combine_auto_gensym(parts, autogensym(parts[1], scope))
2485
2731
  else
2486
- local _ = _285_0
2487
- local function _286_()
2732
+ local _ = _284_0
2733
+ local function _285_()
2488
2734
  local mangling = gensym(scope, base:sub(1, -2), "auto")
2489
2735
  scope.autogensyms[base] = mangling
2490
2736
  return mangling
2491
2737
  end
2492
- return (scope.autogensyms[base] or _286_())
2738
+ return (scope.autogensyms[base] or _285_())
2493
2739
  end
2494
2740
  end
2495
2741
  local function check_binding_valid(symbol, scope, ast, _3fopts)
2496
2742
  local name = tostring(symbol)
2497
2743
  local macro_3f = nil
2498
2744
  do
2499
- local _288_0 = _3fopts
2500
- if (nil ~= _288_0) then
2501
- _288_0 = _288_0["macro?"]
2745
+ local _287_0 = _3fopts
2746
+ if (nil ~= _287_0) then
2747
+ _287_0 = _287_0["macro?"]
2502
2748
  end
2503
- macro_3f = _288_0
2749
+ macro_3f = _287_0
2504
2750
  end
2505
2751
  assert_compile(("&" ~= name:match("[&.:]")), "invalid character: &", symbol)
2506
2752
  assert_compile(not name:find("^%."), "invalid character: .", symbol)
2507
2753
  assert_compile(not (scope.specials[name] or (not macro_3f and scope.macros[name])), ("local %s was overshadowed by a special form or macro"):format(name), ast)
2508
2754
  return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol)
2509
2755
  end
2510
- local function declare_local(symbol, meta, scope, ast, _3ftemp_manglings)
2756
+ local function declare_local(symbol, scope, ast, _3fvar_3f, _3fdeferred_scope_changes)
2511
2757
  check_binding_valid(symbol, scope, ast)
2512
- local name = tostring(symbol)
2513
- assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast)
2514
- scope.symmeta[name] = meta
2515
- return local_mangling(name, scope, ast, _3ftemp_manglings)
2758
+ assert_compile(not utils["multi-sym?"](symbol), ("unexpected multi symbol " .. tostring(symbol)), ast)
2759
+ local str = tostring(symbol)
2760
+ local raw = nil
2761
+ if (utils["lua-keyword?"](str) or str:match("^%d")) then
2762
+ raw = ("_" .. str)
2763
+ else
2764
+ raw = str
2765
+ end
2766
+ local mangling = nil
2767
+ local function _290_(_241)
2768
+ return string.format("_%02x", _241:byte())
2769
+ end
2770
+ mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _290_)
2771
+ local unique = unique_mangling(mangling, mangling, scope, 0)
2772
+ scope.unmanglings[unique] = (scope["gensym-base"][str] or str)
2773
+ do
2774
+ local target = (_3fdeferred_scope_changes or scope)
2775
+ target.manglings[str] = unique
2776
+ target.symmeta[str] = {symbol = symbol, var = _3fvar_3f}
2777
+ end
2778
+ return unique
2516
2779
  end
2517
2780
  local function hashfn_arg_name(name, multi_sym_parts, scope)
2518
2781
  if not scope.hashfn then
@@ -2536,6 +2799,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2536
2799
  local local_3f = scope.manglings[parts[1]]
2537
2800
  if (local_3f and scope.symmeta[parts[1]]) then
2538
2801
  scope.symmeta[parts[1]]["used"] = true
2802
+ symbol.referent = scope.symmeta[parts[1]].symbol
2539
2803
  end
2540
2804
  assert_compile(not scope.macros[parts[1]], "tried to reference a macro without calling it", symbol)
2541
2805
  assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form without calling it", symbol)
@@ -2566,7 +2830,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2566
2830
  end
2567
2831
  return new_chunk
2568
2832
  else
2569
- return utils.map(chunk, peephole)
2833
+ local tbl_17_ = {}
2834
+ local i_18_ = #tbl_17_
2835
+ for _, x in ipairs(chunk) do
2836
+ local val_19_ = peephole(x)
2837
+ if (nil ~= val_19_) then
2838
+ i_18_ = (i_18_ + 1)
2839
+ tbl_17_[i_18_] = val_19_
2840
+ end
2841
+ end
2842
+ return tbl_17_
2570
2843
  end
2571
2844
  end
2572
2845
  local function flatten_chunk_correlated(main_chunk, options)
@@ -2598,38 +2871,57 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2598
2871
  end
2599
2872
  local function flatten_chunk(file_sourcemap, chunk, tab, depth)
2600
2873
  if chunk.leaf then
2601
- local _300_ = utils["ast-source"](chunk.ast)
2602
- local filename = _300_["filename"]
2603
- local line = _300_["line"]
2604
- table.insert(file_sourcemap, {filename, line})
2874
+ local _302_ = utils["ast-source"](chunk.ast)
2875
+ local endline = _302_["endline"]
2876
+ local filename = _302_["filename"]
2877
+ local line = _302_["line"]
2878
+ if ("end" == chunk.leaf) then
2879
+ table.insert(file_sourcemap, {filename, (endline or line)})
2880
+ else
2881
+ table.insert(file_sourcemap, {filename, line})
2882
+ end
2605
2883
  return chunk.leaf
2606
2884
  else
2607
2885
  local tab0 = nil
2608
2886
  do
2609
- local _301_0 = tab
2610
- if (_301_0 == true) then
2887
+ local _304_0 = tab
2888
+ if (_304_0 == true) then
2611
2889
  tab0 = " "
2612
- elseif (_301_0 == false) then
2890
+ elseif (_304_0 == false) then
2613
2891
  tab0 = ""
2614
- elseif (_301_0 == tab) then
2615
- tab0 = tab
2616
- elseif (_301_0 == nil) then
2892
+ elseif (nil ~= _304_0) then
2893
+ local tab1 = _304_0
2894
+ tab0 = tab1
2895
+ elseif (_304_0 == nil) then
2617
2896
  tab0 = ""
2618
2897
  else
2619
2898
  tab0 = nil
2620
2899
  end
2621
2900
  end
2622
- local function parter(c)
2623
- if (c.leaf or next(c)) then
2624
- local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1))
2625
- if (0 < depth) then
2626
- return (tab0 .. sub:gsub("\n", ("\n" .. tab0)))
2901
+ local _306_
2902
+ do
2903
+ local tbl_17_ = {}
2904
+ local i_18_ = #tbl_17_
2905
+ for _, c in ipairs(chunk) do
2906
+ local val_19_ = nil
2907
+ if (c.leaf or next(c)) then
2908
+ local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1))
2909
+ if (0 < depth) then
2910
+ val_19_ = (tab0 .. sub:gsub("\n", ("\n" .. tab0)))
2911
+ else
2912
+ val_19_ = sub
2913
+ end
2627
2914
  else
2628
- return sub
2915
+ val_19_ = nil
2916
+ end
2917
+ if (nil ~= val_19_) then
2918
+ i_18_ = (i_18_ + 1)
2919
+ tbl_17_[i_18_] = val_19_
2629
2920
  end
2630
2921
  end
2922
+ _306_ = tbl_17_
2631
2923
  end
2632
- return table.concat(utils.map(chunk, parter), "\n")
2924
+ return table.concat(_306_, "\n")
2633
2925
  end
2634
2926
  end
2635
2927
  local sourcemap = {}
@@ -2659,7 +2951,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2659
2951
  end
2660
2952
  end
2661
2953
  local function make_metadata()
2662
- local function _309_(self, tgt, _3fkey)
2954
+ local function _314_(self, tgt, _3fkey)
2663
2955
  if self[tgt] then
2664
2956
  if (nil ~= _3fkey) then
2665
2957
  return self[tgt][_3fkey]
@@ -2668,12 +2960,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2668
2960
  end
2669
2961
  end
2670
2962
  end
2671
- local function _312_(self, tgt, key, value)
2963
+ local function _317_(self, tgt, key, value)
2672
2964
  self[tgt] = (self[tgt] or {})
2673
2965
  self[tgt][key] = value
2674
2966
  return tgt
2675
2967
  end
2676
- local function _313_(self, tgt, ...)
2968
+ local function _318_(self, tgt, ...)
2677
2969
  local kv_len = select("#", ...)
2678
2970
  local kvs = {...}
2679
2971
  if ((kv_len % 2) ~= 0) then
@@ -2685,19 +2977,31 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2685
2977
  end
2686
2978
  return tgt
2687
2979
  end
2688
- return setmetatable({}, {__index = {get = _309_, set = _312_, setall = _313_}, __mode = "k"})
2980
+ return setmetatable({}, {__index = {get = _314_, set = _317_, setall = _318_}, __mode = "k"})
2689
2981
  end
2690
2982
  local function exprs1(exprs)
2691
- return table.concat(utils.map(exprs, tostring), ", ")
2692
- end
2693
- local function keep_side_effects(exprs, chunk, start, ast)
2694
- local start0 = (start or 1)
2695
- for j = start0, #exprs do
2696
- local se = exprs[j]
2697
- if ((se.type == "expression") and (se[1] ~= "nil")) then
2698
- emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
2699
- elseif (se.type == "statement") then
2700
- local code = tostring(se)
2983
+ local _320_
2984
+ do
2985
+ local tbl_17_ = {}
2986
+ local i_18_ = #tbl_17_
2987
+ for _, e in ipairs(exprs) do
2988
+ local val_19_ = tostring(e)
2989
+ if (nil ~= val_19_) then
2990
+ i_18_ = (i_18_ + 1)
2991
+ tbl_17_[i_18_] = val_19_
2992
+ end
2993
+ end
2994
+ _320_ = tbl_17_
2995
+ end
2996
+ return table.concat(_320_, ", ")
2997
+ end
2998
+ local function keep_side_effects(exprs, chunk, _3fstart, ast)
2999
+ for j = (_3fstart or 1), #exprs do
3000
+ local subexp = exprs[j]
3001
+ if ((subexp.type == "expression") and (subexp[1] ~= "nil")) then
3002
+ emit(chunk, ("do local _ = %s end"):format(tostring(subexp)), ast)
3003
+ elseif (subexp.type == "statement") then
3004
+ local code = tostring(subexp)
2701
3005
  local disambiguated = nil
2702
3006
  if (code:byte() == 40) then
2703
3007
  disambiguated = ("do end " .. code)
@@ -2731,14 +3035,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2731
3035
  end
2732
3036
  if opts.target then
2733
3037
  local result = exprs1(exprs)
2734
- local function _321_()
3038
+ local function _328_()
2735
3039
  if (result == "") then
2736
3040
  return "nil"
2737
3041
  else
2738
3042
  return result
2739
3043
  end
2740
3044
  end
2741
- emit(parent, string.format("%s = %s", opts.target, _321_()), ast)
3045
+ emit(parent, string.format("%s = %s", opts.target, _328_()), ast)
2742
3046
  end
2743
3047
  if (opts.tail or opts.target) then
2744
3048
  return {returned = true}
@@ -2750,16 +3054,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2750
3054
  local function find_macro(ast, scope)
2751
3055
  local macro_2a = nil
2752
3056
  do
2753
- local _324_0 = utils["sym?"](ast[1])
2754
- if (_324_0 ~= nil) then
2755
- local _325_0 = tostring(_324_0)
2756
- if (_325_0 ~= nil) then
2757
- macro_2a = scope.macros[_325_0]
3057
+ local _331_0 = utils["sym?"](ast[1])
3058
+ if (_331_0 ~= nil) then
3059
+ local _332_0 = tostring(_331_0)
3060
+ if (_332_0 ~= nil) then
3061
+ macro_2a = scope.macros[_332_0]
2758
3062
  else
2759
- macro_2a = _325_0
3063
+ macro_2a = _332_0
2760
3064
  end
2761
3065
  else
2762
- macro_2a = _324_0
3066
+ macro_2a = _331_0
2763
3067
  end
2764
3068
  end
2765
3069
  local multi_sym_parts = utils["multi-sym?"](ast[1])
@@ -2771,12 +3075,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2771
3075
  return macro_2a
2772
3076
  end
2773
3077
  end
2774
- local function propagate_trace_info(_329_0, _index, node)
2775
- local _330_ = _329_0
2776
- local byteend = _330_["byteend"]
2777
- local bytestart = _330_["bytestart"]
2778
- local filename = _330_["filename"]
2779
- local line = _330_["line"]
3078
+ local function propagate_trace_info(_336_0, _index, node)
3079
+ local _337_ = _336_0
3080
+ local byteend = _337_["byteend"]
3081
+ local bytestart = _337_["bytestart"]
3082
+ local filename = _337_["filename"]
3083
+ local line = _337_["line"]
2780
3084
  do
2781
3085
  local src = utils["ast-source"](node)
2782
3086
  if (("table" == type(node)) and (filename ~= src.filename)) then
@@ -2789,20 +3093,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2789
3093
  local function quote_literal_nils(index, node, parent)
2790
3094
  if (parent and utils["list?"](parent)) then
2791
3095
  for i = 1, utils.maxn(parent) do
2792
- local _332_0 = parent[i]
2793
- if (_332_0 == nil) then
3096
+ local _339_0 = parent[i]
3097
+ if (_339_0 == nil) then
2794
3098
  parent[i] = utils.sym("nil")
2795
3099
  end
2796
3100
  end
2797
3101
  end
2798
3102
  return index, node, parent
2799
3103
  end
2800
- local function comp(f, g)
2801
- local function _335_(...)
2802
- return f(g(...))
2803
- end
2804
- return _335_
2805
- end
2806
3104
  local function built_in_3f(m)
2807
3105
  local found_3f = false
2808
3106
  for _, f in pairs(scopes.global.macros) do
@@ -2812,36 +3110,36 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2812
3110
  return found_3f
2813
3111
  end
2814
3112
  local function macroexpand_2a(ast, scope, _3fonce)
2815
- local _336_0 = nil
3113
+ local _342_0 = nil
2816
3114
  if utils["list?"](ast) then
2817
- _336_0 = find_macro(ast, scope)
3115
+ _342_0 = find_macro(ast, scope)
2818
3116
  else
2819
- _336_0 = nil
3117
+ _342_0 = nil
2820
3118
  end
2821
- if (_336_0 == false) then
3119
+ if (_342_0 == false) then
2822
3120
  return ast
2823
- elseif (nil ~= _336_0) then
2824
- local macro_2a = _336_0
3121
+ elseif (nil ~= _342_0) then
3122
+ local macro_2a = _342_0
2825
3123
  local old_scope = scopes.macro
2826
3124
  local _ = nil
2827
3125
  scopes.macro = scope
2828
3126
  _ = nil
2829
3127
  local ok, transformed = nil, nil
2830
- local function _338_()
3128
+ local function _344_()
2831
3129
  return macro_2a(unpack(ast, 2))
2832
3130
  end
2833
- local function _339_()
3131
+ local function _345_()
2834
3132
  if built_in_3f(macro_2a) then
2835
3133
  return tostring
2836
3134
  else
2837
3135
  return debug.traceback
2838
3136
  end
2839
3137
  end
2840
- ok, transformed = xpcall(_338_, _339_())
2841
- local function _340_(...)
2842
- return propagate_trace_info(ast, ...)
3138
+ ok, transformed = xpcall(_344_, _345_())
3139
+ local function _346_(...)
3140
+ return propagate_trace_info(ast, quote_literal_nils(...))
2843
3141
  end
2844
- utils["walk-tree"](transformed, comp(_340_, quote_literal_nils))
3142
+ utils["walk-tree"](transformed, _346_)
2845
3143
  scopes.macro = old_scope
2846
3144
  assert_compile(ok, transformed, ast)
2847
3145
  utils.hook("macroexpand", ast, transformed, scope)
@@ -2851,7 +3149,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2851
3149
  return macroexpand_2a(transformed, scope)
2852
3150
  end
2853
3151
  else
2854
- local _ = _336_0
3152
+ local _ = _342_0
2855
3153
  return ast
2856
3154
  end
2857
3155
  end
@@ -2877,19 +3175,30 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2877
3175
  return exprs2
2878
3176
  end
2879
3177
  end
3178
+ local function callable_3f(_352_0, ctype, callee)
3179
+ local _353_ = _352_0
3180
+ local call_ast = _353_[1]
3181
+ if ("literal" == ctype) then
3182
+ return ("\"" == string.sub(callee, 1, 1))
3183
+ else
3184
+ return (utils["sym?"](call_ast) or utils["list?"](call_ast))
3185
+ end
3186
+ end
2880
3187
  local function compile_function_call(ast, scope, parent, opts, compile1, len)
3188
+ local _355_ = compile1(ast[1], scope, parent, {nval = 1})[1]
3189
+ local callee = _355_[1]
3190
+ local ctype = _355_["type"]
2881
3191
  local fargs = {}
2882
- local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
2883
- assert_compile((utils["sym?"](ast[1]) or utils["list?"](ast[1]) or ("string" == type(ast[1]))), ("cannot call literal value " .. tostring(ast[1])), ast)
3192
+ assert_compile(callable_3f(ast, ctype, callee), ("cannot call literal value " .. tostring(ast[1])), ast)
2884
3193
  for i = 2, len do
2885
3194
  local subexprs = nil
2886
- local _346_
3195
+ local _356_
2887
3196
  if (i ~= len) then
2888
- _346_ = 1
3197
+ _356_ = 1
2889
3198
  else
2890
- _346_ = nil
3199
+ _356_ = nil
2891
3200
  end
2892
- subexprs = compile1(ast[i], scope, parent, {nval = _346_})
3201
+ subexprs = compile1(ast[i], scope, parent, {nval = _356_})
2893
3202
  table.insert(fargs, subexprs[1])
2894
3203
  if (i == len) then
2895
3204
  for j = 2, #subexprs do
@@ -2900,12 +3209,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2900
3209
  end
2901
3210
  end
2902
3211
  local pat = nil
2903
- if ("string" == type(ast[1])) then
3212
+ if ("literal" == ctype) then
2904
3213
  pat = "(%s)(%s)"
2905
3214
  else
2906
3215
  pat = "%s(%s)"
2907
3216
  end
2908
- local call = string.format(pat, tostring(fcallee), exprs1(fargs))
3217
+ local call = string.format(pat, tostring(callee), exprs1(fargs))
2909
3218
  return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
2910
3219
  end
2911
3220
  local function compile_call(ast, scope, parent, opts, compile1)
@@ -2927,13 +3236,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2927
3236
  end
2928
3237
  end
2929
3238
  local function compile_varg(ast, scope, parent, opts)
2930
- local _351_
3239
+ local _361_
2931
3240
  if scope.hashfn then
2932
- _351_ = "use $... in hashfn"
3241
+ _361_ = "use $... in hashfn"
2933
3242
  else
2934
- _351_ = "unexpected vararg"
3243
+ _361_ = "unexpected vararg"
2935
3244
  end
2936
- assert_compile(scope.vararg, _351_, ast)
3245
+ assert_compile(scope.vararg, _361_, ast)
2937
3246
  return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast)
2938
3247
  end
2939
3248
  local function compile_sym(ast, scope, parent, opts)
@@ -2948,20 +3257,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2948
3257
  return handle_compile_opts({e}, parent, opts, ast)
2949
3258
  end
2950
3259
  local function serialize_number(n)
2951
- local _354_0 = string.gsub(tostring(n), ",", ".")
2952
- return _354_0
3260
+ local _364_0 = string.gsub(tostring(n), ",", ".")
3261
+ return _364_0
2953
3262
  end
2954
3263
  local function compile_scalar(ast, _scope, parent, opts)
2955
3264
  local serialize = nil
2956
3265
  do
2957
- local _355_0 = type(ast)
2958
- if (_355_0 == "nil") then
3266
+ local _365_0 = type(ast)
3267
+ if (_365_0 == "nil") then
2959
3268
  serialize = tostring
2960
- elseif (_355_0 == "boolean") then
3269
+ elseif (_365_0 == "boolean") then
2961
3270
  serialize = tostring
2962
- elseif (_355_0 == "string") then
3271
+ elseif (_365_0 == "string") then
2963
3272
  serialize = serialize_string
2964
- elseif (_355_0 == "number") then
3273
+ elseif (_365_0 == "number") then
2965
3274
  serialize = serialize_number
2966
3275
  else
2967
3276
  serialize = nil
@@ -2974,8 +3283,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
2974
3283
  if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then
2975
3284
  return k
2976
3285
  else
2977
- local _357_ = compile1(k, scope, parent, {nval = 1})
2978
- local compiled = _357_[1]
3286
+ local _367_ = compile1(k, scope, parent, {nval = 1})
3287
+ local compiled = _367_[1]
2979
3288
  return ("[" .. tostring(compiled) .. "]")
2980
3289
  end
2981
3290
  end
@@ -3004,8 +3313,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3004
3313
  for k in utils.stablepairs(ast) do
3005
3314
  local val_19_ = nil
3006
3315
  if not keys[k] then
3007
- local _360_ = compile1(ast[k], scope, parent, {nval = 1})
3008
- local v = _360_[1]
3316
+ local _370_ = compile1(ast[k], scope, parent, {nval = 1})
3317
+ local v = _370_[1]
3009
3318
  val_19_ = string.format("%s = %s", escape_key(k), tostring(v))
3010
3319
  else
3011
3320
  val_19_ = nil
@@ -3037,12 +3346,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3037
3346
  end
3038
3347
  local function destructure(to, from, ast, scope, parent, opts)
3039
3348
  local opts0 = (opts or {})
3040
- local _364_ = opts0
3041
- local declaration = _364_["declaration"]
3042
- local forceglobal = _364_["forceglobal"]
3043
- local forceset = _364_["forceset"]
3044
- local isvar = _364_["isvar"]
3045
- local symtype = _364_["symtype"]
3349
+ local _374_ = opts0
3350
+ local declaration = _374_["declaration"]
3351
+ local forceglobal = _374_["forceglobal"]
3352
+ local forceset = _374_["forceset"]
3353
+ local isvar = _374_["isvar"]
3354
+ local symtype = _374_["symtype"]
3046
3355
  local symtype0 = ("_" .. (symtype or "dst"))
3047
3356
  local setter = nil
3048
3357
  if declaration then
@@ -3050,16 +3359,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3050
3359
  else
3051
3360
  setter = "%s = %s"
3052
3361
  end
3053
- local new_manglings = {}
3054
- local function getname(symbol, up1)
3362
+ local deferred_scope_changes = {manglings = {}, symmeta = {}}
3363
+ local function getname(symbol, ast0)
3055
3364
  local raw = symbol[1]
3056
- assert_compile(not (opts0.nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1)
3365
+ assert_compile(not (opts0.nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), ast0)
3057
3366
  if declaration then
3058
- return declare_local(symbol, nil, scope, symbol, new_manglings)
3367
+ return declare_local(symbol, scope, symbol, isvar, deferred_scope_changes)
3059
3368
  else
3060
3369
  local parts = (utils["multi-sym?"](raw) or {raw})
3061
- local _366_ = parts
3062
- local first = _366_[1]
3370
+ local _376_ = parts
3371
+ local first = _376_[1]
3063
3372
  local meta = scope.symmeta[first]
3064
3373
  assert_compile(not raw:find(":"), "cannot set method sym", symbol)
3065
3374
  if ((#parts == 1) and not forceset) then
@@ -3080,14 +3389,23 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3080
3389
  end
3081
3390
  local function compile_top_target(lvalues)
3082
3391
  local inits = nil
3083
- local function _371_(_241)
3084
- if scope.manglings[_241] then
3085
- return _241
3086
- else
3087
- return "nil"
3392
+ do
3393
+ local tbl_17_ = {}
3394
+ local i_18_ = #tbl_17_
3395
+ for _, l in ipairs(lvalues) do
3396
+ local val_19_ = nil
3397
+ if scope.manglings[l] then
3398
+ val_19_ = l
3399
+ else
3400
+ val_19_ = "nil"
3401
+ end
3402
+ if (nil ~= val_19_) then
3403
+ i_18_ = (i_18_ + 1)
3404
+ tbl_17_[i_18_] = val_19_
3405
+ end
3088
3406
  end
3407
+ inits = tbl_17_
3089
3408
  end
3090
- inits = utils.map(lvalues, _371_)
3091
3409
  local init = table.concat(inits, ", ")
3092
3410
  local lvalue = table.concat(lvalues, ", ")
3093
3411
  local plast = parent[#parent]
@@ -3113,19 +3431,70 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3113
3431
  local lname = getname(left, up1)
3114
3432
  check_binding_valid(left, scope, left)
3115
3433
  if top_3f then
3116
- compile_top_target({lname})
3434
+ return compile_top_target({lname})
3117
3435
  else
3118
- emit(parent, setter:format(lname, exprs1(rightexprs)), left)
3436
+ return emit(parent, setter:format(lname, exprs1(rightexprs)), left)
3119
3437
  end
3120
- if declaration then
3121
- scope.symmeta[tostring(left)] = {var = isvar}
3122
- return nil
3438
+ end
3439
+ local function dynamic_set_target(_387_0)
3440
+ local _388_ = _387_0
3441
+ local _ = _388_[1]
3442
+ local target = _388_[2]
3443
+ local keys = {(table.unpack or unpack)(_388_, 3)}
3444
+ assert_compile(utils["sym?"](target), "dynamic set needs symbol target", ast)
3445
+ assert_compile(scope.manglings[tostring(target)], ("unknown identifier: " .. tostring(target)), target)
3446
+ local keys0 = nil
3447
+ do
3448
+ local tbl_17_ = {}
3449
+ local i_18_ = #tbl_17_
3450
+ for _0, k in ipairs(keys) do
3451
+ local val_19_ = tostring(compile1(k, scope, parent, {nval = 1})[1])
3452
+ if (nil ~= val_19_) then
3453
+ i_18_ = (i_18_ + 1)
3454
+ tbl_17_[i_18_] = val_19_
3455
+ end
3456
+ end
3457
+ keys0 = tbl_17_
3458
+ end
3459
+ return string.format("%s[%s]", tostring(symbol_to_expression(target, scope, true)), table.concat(keys0, "]["))
3460
+ end
3461
+ local function destructure_values(left, rightexprs, up1, destructure1, top_3f)
3462
+ local left_names, tables = {}, {}
3463
+ for i, name in ipairs(left) do
3464
+ if utils["sym?"](name) then
3465
+ table.insert(left_names, getname(name, up1))
3466
+ elseif utils["call-of?"](name, ".") then
3467
+ table.insert(left_names, dynamic_set_target(name))
3468
+ else
3469
+ local symname = gensym(scope, symtype0)
3470
+ table.insert(left_names, symname)
3471
+ tables[i] = {name, utils.expr(symname, "sym")}
3472
+ end
3473
+ end
3474
+ assert_compile(left[1], "must provide at least one value", left)
3475
+ if top_3f then
3476
+ compile_top_target(left_names)
3477
+ elseif utils["expr?"](rightexprs) then
3478
+ emit(parent, setter:format(table.concat(left_names, ","), exprs1(rightexprs)), left)
3479
+ else
3480
+ local names = table.concat(left_names, ",")
3481
+ local target = nil
3482
+ if declaration then
3483
+ target = ("local " .. names)
3484
+ else
3485
+ target = names
3486
+ end
3487
+ emit(parent, compile1(rightexprs, scope, parent, {target = target}), left)
3123
3488
  end
3489
+ for _, pair in utils.stablepairs(tables) do
3490
+ destructure1(pair[1], {pair[2]}, left)
3491
+ end
3492
+ return nil
3124
3493
  end
3125
3494
  local unpack_fn = "function (t, k, e)\n local mt = getmetatable(t)\n if 'table' == type(mt) and mt.__fennelrest then\n return mt.__fennelrest(t, k)\n elseif e then\n local rest = {}\n for k, v in pairs(t) do\n if not e[k] then rest[k] = v end\n end\n return rest\n else\n return {(table.unpack or unpack)(t, k)}\n end\n end"
3126
3495
  local function destructure_kv_rest(s, v, left, excluded_keys, destructure1)
3127
3496
  local exclude_str = nil
3128
- local _378_
3497
+ local _393_
3129
3498
  do
3130
3499
  local tbl_17_ = {}
3131
3500
  local i_18_ = #tbl_17_
@@ -3136,9 +3505,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3136
3505
  tbl_17_[i_18_] = val_19_
3137
3506
  end
3138
3507
  end
3139
- _378_ = tbl_17_
3508
+ _393_ = tbl_17_
3140
3509
  end
3141
- exclude_str = table.concat(_378_, ", ")
3510
+ exclude_str = table.concat(_393_, ", ")
3142
3511
  local subexpr = utils.expr(string.format(string.gsub(("(" .. unpack_fn .. ")(%s, %s, {%s})"), "\n%s*", " "), s, tostring(v), exclude_str), "expression")
3143
3512
  return destructure1(v, {subexpr}, left)
3144
3513
  end
@@ -3146,107 +3515,108 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3146
3515
  local unpack_str = ("(" .. unpack_fn .. ")(%s, %s)")
3147
3516
  local formatted = string.format(string.gsub(unpack_str, "\n%s*", " "), s, k)
3148
3517
  local subexpr = utils.expr(formatted, "expression")
3149
- assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left)
3518
+ local function _395_()
3519
+ local next_symbol = left[(k + 2)]
3520
+ return ((nil == next_symbol) or utils["sym?"](next_symbol, "&as"))
3521
+ end
3522
+ assert_compile((utils["sequence?"](left) and _395_()), "expected rest argument before last parameter", left)
3150
3523
  return destructure1(left[(k + 1)], {subexpr}, left)
3151
3524
  end
3152
- local function destructure_table(left, rightexprs, top_3f, destructure1)
3153
- local s = gensym(scope, symtype0)
3154
- local right = nil
3155
- do
3156
- local _380_0 = nil
3157
- if top_3f then
3158
- _380_0 = exprs1(compile1(from, scope, parent))
3159
- else
3160
- _380_0 = exprs1(rightexprs)
3525
+ local function optimize_table_destructure_3f(left, right)
3526
+ local function _396_()
3527
+ local all = next(left)
3528
+ for _, d in ipairs(left) do
3529
+ if not all then break end
3530
+ all = ((utils["sym?"](d) and not tostring(d):find("^&")) or (utils["list?"](d) and utils["sym?"](d[1], ".")))
3161
3531
  end
3162
- if (_380_0 == "") then
3163
- right = "nil"
3164
- elseif (nil ~= _380_0) then
3165
- local right0 = _380_0
3166
- right = right0
3167
- else
3168
- right = nil
3169
- end
3170
- end
3171
- local excluded_keys = {}
3172
- emit(parent, string.format("local %s = %s", s, right), left)
3173
- for k, v in utils.stablepairs(left) do
3174
- if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then
3175
- if (utils["sym?"](k) and (tostring(k) == "&")) then
3176
- destructure_kv_rest(s, v, left, excluded_keys, destructure1)
3177
- elseif (utils["sym?"](v) and (tostring(v) == "&")) then
3178
- destructure_rest(s, k, left, destructure1)
3179
- elseif (utils["sym?"](k) and (tostring(k) == "&as")) then
3180
- destructure_sym(v, {utils.expr(tostring(s))}, left)
3181
- elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then
3182
- local _, next_sym, trailing = select(k, unpack(left))
3183
- assert_compile((nil == trailing), "expected &as argument before last parameter", left)
3184
- destructure_sym(next_sym, {utils.expr(tostring(s))}, left)
3532
+ return all
3533
+ end
3534
+ return (utils["sequence?"](left) and utils["sequence?"](right) and _396_())
3535
+ end
3536
+ local function destructure_table(left, rightexprs, top_3f, destructure1, up1)
3537
+ if optimize_table_destructure_3f(left, rightexprs) then
3538
+ return destructure_values(utils.list(unpack(left)), utils.list(utils.sym("values"), unpack(rightexprs)), up1, destructure1)
3539
+ else
3540
+ local right = nil
3541
+ do
3542
+ local _397_0 = nil
3543
+ if top_3f then
3544
+ _397_0 = exprs1(compile1(from, scope, parent))
3185
3545
  else
3186
- local key = nil
3187
- if (type(k) == "string") then
3188
- key = serialize_string(k)
3189
- else
3190
- key = k
3191
- end
3192
- local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression")
3193
- if (type(k) == "string") then
3194
- table.insert(excluded_keys, k)
3195
- end
3196
- destructure1(v, {subexpr}, left)
3546
+ _397_0 = exprs1(rightexprs)
3547
+ end
3548
+ if (_397_0 == "") then
3549
+ right = "nil"
3550
+ elseif (nil ~= _397_0) then
3551
+ local right0 = _397_0
3552
+ right = right0
3553
+ else
3554
+ right = nil
3197
3555
  end
3198
3556
  end
3199
- end
3200
- return nil
3201
- end
3202
- local function destructure_values(left, up1, top_3f, destructure1)
3203
- local left_names, tables = {}, {}
3204
- for i, name in ipairs(left) do
3205
- if utils["sym?"](name) then
3206
- table.insert(left_names, getname(name, up1))
3557
+ local s = nil
3558
+ if utils["sym?"](rightexprs) then
3559
+ s = right
3207
3560
  else
3208
- local symname = gensym(scope, symtype0)
3209
- table.insert(left_names, symname)
3210
- tables[i] = {name, utils.expr(symname, "sym")}
3211
- end
3212
- end
3213
- assert_compile(left[1], "must provide at least one value", left)
3214
- assert_compile(top_3f, "can't nest multi-value destructuring", left)
3215
- compile_top_target(left_names)
3216
- if declaration then
3217
- for _, sym in ipairs(left) do
3218
- if utils["sym?"](sym) then
3219
- scope.symmeta[tostring(sym)] = {var = isvar}
3561
+ s = gensym(scope, symtype0)
3562
+ end
3563
+ local excluded_keys = {}
3564
+ if not utils["sym?"](rightexprs) then
3565
+ emit(parent, string.format("local %s = %s", s, right), left)
3566
+ end
3567
+ for k, v in utils.stablepairs(left) do
3568
+ if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then
3569
+ if (utils["sym?"](k) and (tostring(k) == "&")) then
3570
+ destructure_kv_rest(s, v, left, excluded_keys, destructure1)
3571
+ elseif (utils["sym?"](v) and (tostring(v) == "&")) then
3572
+ destructure_rest(s, k, left, destructure1)
3573
+ elseif (utils["sym?"](k) and (tostring(k) == "&as")) then
3574
+ destructure_sym(v, {utils.expr(tostring(s))}, left)
3575
+ elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then
3576
+ local _, next_sym, trailing = select(k, unpack(left))
3577
+ assert_compile((nil == trailing), "expected &as argument before last parameter", left)
3578
+ destructure_sym(next_sym, {utils.expr(tostring(s))}, left)
3579
+ else
3580
+ local key = nil
3581
+ if (type(k) == "string") then
3582
+ key = serialize_string(k)
3583
+ else
3584
+ key = k
3585
+ end
3586
+ local subexpr = utils.expr(("%s[%s]"):format(s, key), "expression")
3587
+ if (type(k) == "string") then
3588
+ table.insert(excluded_keys, k)
3589
+ end
3590
+ destructure1(v, subexpr, left)
3591
+ end
3220
3592
  end
3221
3593
  end
3594
+ return nil
3222
3595
  end
3223
- for _, pair in utils.stablepairs(tables) do
3224
- destructure1(pair[1], {pair[2]}, left)
3225
- end
3226
- return nil
3227
3596
  end
3228
3597
  local function destructure1(left, rightexprs, up1, top_3f)
3229
3598
  if (utils["sym?"](left) and (left[1] ~= "nil")) then
3230
3599
  destructure_sym(left, rightexprs, up1, top_3f)
3231
3600
  elseif utils["table?"](left) then
3232
- destructure_table(left, rightexprs, top_3f, destructure1)
3601
+ destructure_table(left, rightexprs, top_3f, destructure1, up1)
3602
+ elseif utils["call-of?"](left, ".") then
3603
+ destructure_values({left}, rightexprs, up1, destructure1)
3233
3604
  elseif utils["list?"](left) then
3234
- destructure_values(left, up1, top_3f, destructure1)
3605
+ assert_compile(top_3f, "can't nest multi-value destructuring", left)
3606
+ destructure_values(left, rightexprs, up1, destructure1, true)
3235
3607
  else
3236
3608
  assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1))
3237
3609
  end
3238
- if top_3f then
3239
- return {returned = true}
3240
- end
3610
+ return (top_3f and {returned = true})
3241
3611
  end
3242
- local ret = destructure1(to, nil, ast, true)
3612
+ local ret = destructure1(to, from, ast, true)
3243
3613
  utils.hook("destructure", from, to, scope, opts0)
3244
- apply_manglings(scope, new_manglings, ast)
3614
+ apply_deferred_scope_changes(scope, deferred_scope_changes, ast)
3245
3615
  return ret
3246
3616
  end
3247
3617
  local function require_include(ast, scope, parent, opts)
3248
3618
  opts.fallback = function(e, no_warn)
3249
- if (not no_warn and ("literal" == e.type)) then
3619
+ if not no_warn then
3250
3620
  utils.warn(("include module not found, falling back to require: %s"):format(tostring(e)), ast)
3251
3621
  end
3252
3622
  return utils.expr(string.format("require(%s)", tostring(e)), "statement")
@@ -3270,8 +3640,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3270
3640
  if opts.assertAsRepl then
3271
3641
  scope.macros.assert = scope.macros["assert-repl"]
3272
3642
  end
3273
- local _395_ = utils.root
3274
- _395_["set-reset"](_395_)
3643
+ local _411_ = utils.root
3644
+ _411_["set-reset"](_411_)
3275
3645
  utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
3276
3646
  for i = 1, #asts do
3277
3647
  local exprs = compile1(asts[i], scope, chunk, {nval = (((i < #asts) and 0) or nil), tail = (i == #asts)})
@@ -3304,8 +3674,24 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3304
3674
  local function compile_string(str, _3fopts)
3305
3675
  return compile_stream(parser["string-stream"](str, _3fopts), _3fopts)
3306
3676
  end
3307
- local function compile(ast, _3fopts)
3308
- return compile_asts({ast}, _3fopts)
3677
+ local function compile(from, _3fopts)
3678
+ local _414_0 = type(from)
3679
+ if (_414_0 == "userdata") then
3680
+ local function _415_()
3681
+ local _416_0 = from:read(1)
3682
+ if (nil ~= _416_0) then
3683
+ return _416_0:byte()
3684
+ else
3685
+ return _416_0
3686
+ end
3687
+ end
3688
+ return compile_stream(_415_, _3fopts)
3689
+ elseif (_414_0 == "function") then
3690
+ return compile_stream(from, _3fopts)
3691
+ else
3692
+ local _ = _414_0
3693
+ return compile_asts({from}, _3fopts)
3694
+ end
3309
3695
  end
3310
3696
  local function traceback_frame(info)
3311
3697
  if ((info.what == "C") and info.name) then
@@ -3323,14 +3709,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3323
3709
  info.currentline = (remap[info.currentline][2] or -1)
3324
3710
  end
3325
3711
  if (info.what == "Lua") then
3326
- local function _400_()
3712
+ local function _421_()
3327
3713
  if info.name then
3328
3714
  return ("'" .. info.name .. "'")
3329
3715
  else
3330
3716
  return "?"
3331
3717
  end
3332
3718
  end
3333
- return string.format("\9%s:%d: in function %s", info.short_src, info.currentline, _400_())
3719
+ return string.format("\9%s:%d: in function %s", info.short_src, info.currentline, _421_())
3334
3720
  elseif (info.short_src == "(tail call)") then
3335
3721
  return " (tail call)"
3336
3722
  else
@@ -3338,6 +3724,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3338
3724
  end
3339
3725
  end
3340
3726
  end
3727
+ local lua_getinfo = debug.getinfo
3341
3728
  local function traceback(_3fmsg, _3fstart)
3342
3729
  local msg = tostring((_3fmsg or ""))
3343
3730
  if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then
@@ -3354,11 +3741,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3354
3741
  local done_3f, level = false, (_3fstart or 2)
3355
3742
  while not done_3f do
3356
3743
  do
3357
- local _404_0 = debug.getinfo(level, "Sln")
3358
- if (_404_0 == nil) then
3744
+ local _425_0 = lua_getinfo(level, "Sln")
3745
+ if (_425_0 == nil) then
3359
3746
  done_3f = true
3360
- elseif (nil ~= _404_0) then
3361
- local info = _404_0
3747
+ elseif (nil ~= _425_0) then
3748
+ local info = _425_0
3362
3749
  table.insert(lines, traceback_frame(info))
3363
3750
  end
3364
3751
  end
@@ -3367,15 +3754,47 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3367
3754
  return table.concat(lines, "\n")
3368
3755
  end
3369
3756
  end
3370
- local function entry_transform(fk, fv)
3371
- local function _407_(k, v)
3372
- if (type(k) == "number") then
3373
- return k, fv(v)
3374
- else
3375
- return fk(k), fv(v)
3757
+ local function getinfo(thread_or_level, ...)
3758
+ local thread_or_level0 = nil
3759
+ if ("number" == type(thread_or_level)) then
3760
+ thread_or_level0 = (1 + thread_or_level)
3761
+ else
3762
+ thread_or_level0 = thread_or_level
3763
+ end
3764
+ local info = lua_getinfo(thread_or_level0, ...)
3765
+ local mapped = (info and sourcemap[info.source])
3766
+ if mapped then
3767
+ for _, key in ipairs({"currentline", "linedefined", "lastlinedefined"}) do
3768
+ local mapped_value = nil
3769
+ do
3770
+ local _429_0 = mapped
3771
+ if (nil ~= _429_0) then
3772
+ _429_0 = _429_0[info[key]]
3773
+ end
3774
+ if (nil ~= _429_0) then
3775
+ _429_0 = _429_0[2]
3776
+ end
3777
+ mapped_value = _429_0
3778
+ end
3779
+ if (info[key] and mapped_value) then
3780
+ info[key] = mapped_value
3781
+ end
3782
+ end
3783
+ if info.activelines then
3784
+ local tbl_14_ = {}
3785
+ for line in pairs(info.activelines) do
3786
+ local k_15_, v_16_ = mapped[line][2], true
3787
+ if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
3788
+ tbl_14_[k_15_] = v_16_
3789
+ end
3790
+ end
3791
+ info.activelines = tbl_14_
3792
+ end
3793
+ if (info.what == "Lua") then
3794
+ info.what = "Fennel"
3376
3795
  end
3377
3796
  end
3378
- return _407_
3797
+ return info
3379
3798
  end
3380
3799
  local function mixed_concat(t, joiner)
3381
3800
  local seen = {}
@@ -3394,8 +3813,22 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3394
3813
  return ret
3395
3814
  end
3396
3815
  local function do_quote(form, scope, parent, runtime_3f)
3397
- local function q(x)
3398
- return do_quote(x, scope, parent, runtime_3f)
3816
+ local function quote_all(form0, discard_non_numbers)
3817
+ local tbl_14_ = {}
3818
+ for k, v in utils.stablepairs(form0) do
3819
+ local k_15_, v_16_ = nil, nil
3820
+ if (type(k) == "number") then
3821
+ k_15_, v_16_ = k, do_quote(v, scope, parent, runtime_3f)
3822
+ elseif not discard_non_numbers then
3823
+ k_15_, v_16_ = do_quote(k, scope, parent, runtime_3f), do_quote(v, scope, parent, runtime_3f)
3824
+ else
3825
+ k_15_, v_16_ = nil
3826
+ end
3827
+ if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
3828
+ tbl_14_[k_15_] = v_16_
3829
+ end
3830
+ end
3831
+ return tbl_14_
3399
3832
  end
3400
3833
  if utils["varg?"](form) then
3401
3834
  assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form)
@@ -3414,16 +3847,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3414
3847
  else
3415
3848
  return string.format("sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil"))
3416
3849
  end
3417
- elseif (utils["list?"](form) and utils["sym?"](form[1]) and (tostring(form[1]) == "unquote")) then
3418
- local payload = form[2]
3419
- local res = unpack(compile1(payload, scope, parent))
3850
+ elseif utils["call-of?"](form, "unquote") then
3851
+ local res = unpack(compile1(form[2], scope, parent))
3420
3852
  return res[1]
3421
3853
  elseif utils["list?"](form) then
3422
- local mapped = nil
3423
- local function _412_()
3424
- return nil
3425
- end
3426
- mapped = utils.kvmap(form, entry_transform(_412_, q))
3854
+ local mapped = quote_all(form, true)
3427
3855
  local filename = nil
3428
3856
  if form.filename then
3429
3857
  filename = string.format("%q", form.filename)
@@ -3433,7 +3861,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3433
3861
  assert_compile(not runtime_3f, "lists may only be used at compile time", form)
3434
3862
  return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", "))
3435
3863
  elseif utils["sequence?"](form) then
3436
- local mapped = utils.kvmap(form, entry_transform(q, q))
3864
+ local mapped = quote_all(form)
3437
3865
  local source = getmetatable(form)
3438
3866
  local filename = nil
3439
3867
  if source.filename then
@@ -3441,15 +3869,15 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3441
3869
  else
3442
3870
  filename = "nil"
3443
3871
  end
3444
- local _415_
3872
+ local _444_
3445
3873
  if source then
3446
- _415_ = source.line
3874
+ _444_ = source.line
3447
3875
  else
3448
- _415_ = "nil"
3876
+ _444_ = "nil"
3449
3877
  end
3450
- return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _415_, "(getmetatable(sequence()))['sequence']")
3878
+ return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _444_, "(getmetatable(sequence()))['sequence']")
3451
3879
  elseif (type(form) == "table") then
3452
- local mapped = utils.kvmap(form, entry_transform(q, q))
3880
+ local mapped = quote_all(form)
3453
3881
  local source = getmetatable(form)
3454
3882
  local filename = nil
3455
3883
  if source.filename then
@@ -3457,26 +3885,26 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
3457
3885
  else
3458
3886
  filename = "nil"
3459
3887
  end
3460
- local function _418_()
3888
+ local function _447_()
3461
3889
  if source then
3462
3890
  return source.line
3463
3891
  else
3464
3892
  return "nil"
3465
3893
  end
3466
3894
  end
3467
- return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _418_())
3895
+ return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _447_())
3468
3896
  elseif (type(form) == "string") then
3469
3897
  return serialize_string(form)
3470
3898
  else
3471
3899
  return tostring(form)
3472
3900
  end
3473
3901
  end
3474
- return {["apply-manglings"] = apply_manglings, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, sourcemap = sourcemap, traceback = traceback}
3902
+ return {["apply-deferred-scope-changes"] = apply_deferred_scope_changes, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-allowed?"] = global_allowed_3f, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, getinfo = getinfo, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, sourcemap = sourcemap, traceback = traceback}
3475
3903
  end
3476
3904
  package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...)
3477
3905
  local utils = require("fennel.utils")
3478
3906
  local utf8_ok_3f, utf8 = pcall(require, "utf8")
3479
- local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name", "making sure to use prefix operators, not infix"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected range to include start and stop"] = {"adding missing arguments"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["missing subject"] = {"adding an item to operate on"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["tried to use unquote outside quote"] = {"moving the form to inside a quoted form", "removing the comma"}, ["tried to use vararg with operator"] = {"accumulating over the operands"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown identifier: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
3907
+ local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't introduce (.*) here"] = {"declaring the local at the top-level"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name", "making sure to use prefix operators, not infix"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected range to include start and stop"] = {"adding missing arguments"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["missing subject"] = {"adding an item to operate on"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["tried to use unquote outside quote"] = {"moving the form to inside a quoted form", "removing the comma"}, ["tried to use vararg with operator"] = {"accumulating over the operands"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown identifier: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
3480
3908
  local unpack = (table.unpack or _G.unpack)
3481
3909
  local function suggest(msg)
3482
3910
  local s = nil
@@ -3517,13 +3945,13 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
3517
3945
  return error(..., 0)
3518
3946
  end
3519
3947
  end
3520
- local function _187_()
3948
+ local function _181_()
3521
3949
  for _ = 2, line do
3522
3950
  f:read()
3523
3951
  end
3524
3952
  return f:read()
3525
3953
  end
3526
- return close_handlers_10_(_G.xpcall(_187_, (package.loaded.fennel or debug).traceback))
3954
+ return close_handlers_10_(_G.xpcall(_181_, (package.loaded.fennel or debug).traceback))
3527
3955
  end
3528
3956
  end
3529
3957
  local function sub(str, start, _end)
@@ -3539,8 +3967,8 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
3539
3967
  if ((opts and (false == opts["error-pinpoint"])) or (os and os.getenv and os.getenv("NO_COLOR"))) then
3540
3968
  return codeline
3541
3969
  else
3542
- local _190_ = (opts or {})
3543
- local error_pinpoint = _190_["error-pinpoint"]
3970
+ local _184_ = (opts or {})
3971
+ local error_pinpoint = _184_["error-pinpoint"]
3544
3972
  local endcol = (_3fendcol or col)
3545
3973
  local eol = nil
3546
3974
  if utf8_ok_3f then
@@ -3548,19 +3976,19 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
3548
3976
  else
3549
3977
  eol = string.len(codeline)
3550
3978
  end
3551
- local _192_ = (error_pinpoint or {"\27[7m", "\27[0m"})
3552
- local open = _192_[1]
3553
- local close = _192_[2]
3979
+ local _186_ = (error_pinpoint or {"\27[7m", "\27[0m"})
3980
+ local open = _186_[1]
3981
+ local close = _186_[2]
3554
3982
  return (sub(codeline, 1, col) .. open .. sub(codeline, (col + 1), (endcol + 1)) .. close .. sub(codeline, (endcol + 2), eol))
3555
3983
  end
3556
3984
  end
3557
- local function friendly_msg(msg, _194_0, source, opts)
3558
- local _195_ = _194_0
3559
- local col = _195_["col"]
3560
- local endcol = _195_["endcol"]
3561
- local endline = _195_["endline"]
3562
- local filename = _195_["filename"]
3563
- local line = _195_["line"]
3985
+ local function friendly_msg(msg, _188_0, source, opts)
3986
+ local _189_ = _188_0
3987
+ local col = _189_["col"]
3988
+ local endcol = _189_["endcol"]
3989
+ local endline = _189_["endline"]
3990
+ local filename = _189_["filename"]
3991
+ local line = _189_["line"]
3564
3992
  local ok, codeline = pcall(read_line, filename, line, source)
3565
3993
  local endcol0 = nil
3566
3994
  if (ok and codeline and (line ~= endline)) then
@@ -3583,10 +4011,10 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
3583
4011
  end
3584
4012
  local function assert_compile(condition, msg, ast, source, opts)
3585
4013
  if not condition then
3586
- local _199_ = utils["ast-source"](ast)
3587
- local col = _199_["col"]
3588
- local filename = _199_["filename"]
3589
- local line = _199_["line"]
4014
+ local _193_ = utils["ast-source"](ast)
4015
+ local col = _193_["col"]
4016
+ local filename = _193_["filename"]
4017
+ local line = _193_["line"]
3590
4018
  error(friendly_msg(("%s:%s:%s: Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0)
3591
4019
  end
3592
4020
  return condition
@@ -3602,36 +4030,36 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3602
4030
  local unpack = (table.unpack or _G.unpack)
3603
4031
  local function granulate(getchunk)
3604
4032
  local c, index, done_3f = "", 1, false
3605
- local function _201_(parser_state)
4033
+ local function _195_(parser_state)
3606
4034
  if not done_3f then
3607
4035
  if (index <= #c) then
3608
4036
  local b = c:byte(index)
3609
4037
  index = (index + 1)
3610
4038
  return b
3611
4039
  else
3612
- local _202_0 = getchunk(parser_state)
3613
- local function _203_()
3614
- local char = _202_0
4040
+ local _196_0 = getchunk(parser_state)
4041
+ local function _197_()
4042
+ local char = _196_0
3615
4043
  return (char ~= "")
3616
4044
  end
3617
- if ((nil ~= _202_0) and _203_()) then
3618
- local char = _202_0
4045
+ if ((nil ~= _196_0) and _197_()) then
4046
+ local char = _196_0
3619
4047
  c = char
3620
4048
  index = 2
3621
4049
  return c:byte()
3622
4050
  else
3623
- local _ = _202_0
4051
+ local _ = _196_0
3624
4052
  done_3f = true
3625
4053
  return nil
3626
4054
  end
3627
4055
  end
3628
4056
  end
3629
4057
  end
3630
- local function _207_()
4058
+ local function _201_()
3631
4059
  c = ""
3632
4060
  return nil
3633
4061
  end
3634
- return _201_, _207_
4062
+ return _195_, _201_
3635
4063
  end
3636
4064
  local function string_stream(str, _3foptions)
3637
4065
  local str0 = str:gsub("^#!", ";;")
@@ -3639,12 +4067,12 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3639
4067
  _3foptions.source = str0
3640
4068
  end
3641
4069
  local index = 1
3642
- local function _209_()
4070
+ local function _203_()
3643
4071
  local r = str0:byte(index)
3644
4072
  index = (index + 1)
3645
4073
  return r
3646
4074
  end
3647
- return _209_
4075
+ return _203_
3648
4076
  end
3649
4077
  local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true}
3650
4078
  local function sym_char_3f(b)
@@ -3660,12 +4088,12 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3660
4088
  local function char_starter_3f(b)
3661
4089
  return (((1 < b) and (b < 127)) or ((192 < b) and (b < 247)))
3662
4090
  end
3663
- local function parser_fn(getbyte, filename, _211_0)
3664
- local _212_ = _211_0
3665
- local options = _212_
3666
- local comments = _212_["comments"]
3667
- local source = _212_["source"]
3668
- local unfriendly = _212_["unfriendly"]
4091
+ local function parser_fn(getbyte, filename, _205_0)
4092
+ local _206_ = _205_0
4093
+ local options = _206_
4094
+ local comments = _206_["comments"]
4095
+ local source = _206_["source"]
4096
+ local unfriendly = _206_["unfriendly"]
3669
4097
  local stack = {}
3670
4098
  local line, byteindex, col, prev_col, lastb = 1, 0, 0, 0, nil
3671
4099
  local function ungetb(ub)
@@ -3698,14 +4126,14 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3698
4126
  return r
3699
4127
  end
3700
4128
  local function whitespace_3f(b)
3701
- local function _220_()
3702
- local _219_0 = options.whitespace
3703
- if (nil ~= _219_0) then
3704
- _219_0 = _219_0[b]
4129
+ local function _214_()
4130
+ local _213_0 = options.whitespace
4131
+ if (nil ~= _213_0) then
4132
+ _213_0 = _213_0[b]
3705
4133
  end
3706
- return _219_0
4134
+ return _213_0
3707
4135
  end
3708
- return ((b == 32) or ((9 <= b) and (b <= 13)) or _220_())
4136
+ return ((b == 32) or ((9 <= b) and (b <= 13)) or _214_())
3709
4137
  end
3710
4138
  local function parse_error(msg, _3fcol_adjust)
3711
4139
  local col0 = (col + (_3fcol_adjust or -1))
@@ -3724,39 +4152,61 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3724
4152
  source0.byteend, source0.endcol, source0.endline = byteindex, (col - 1), line
3725
4153
  return nil
3726
4154
  end
3727
- local function dispatch(v)
3728
- local _224_0 = stack[#stack]
3729
- if (_224_0 == nil) then
3730
- retval, done_3f, whitespace_since_dispatch = v, true, false
4155
+ local function dispatch(v, _3fsource, _3fraw)
4156
+ whitespace_since_dispatch = false
4157
+ local v0 = nil
4158
+ do
4159
+ local _218_0 = utils["hook-opts"]("parse-form", options, v, _3fsource, _3fraw, stack)
4160
+ if (nil ~= _218_0) then
4161
+ local hookv = _218_0
4162
+ v0 = hookv
4163
+ else
4164
+ local _ = _218_0
4165
+ v0 = v
4166
+ end
4167
+ end
4168
+ local _220_0 = stack[#stack]
4169
+ if (_220_0 == nil) then
4170
+ retval, done_3f = v0, true
3731
4171
  return nil
3732
- elseif ((_G.type(_224_0) == "table") and (nil ~= _224_0.prefix)) then
3733
- local prefix = _224_0.prefix
4172
+ elseif ((_G.type(_220_0) == "table") and (nil ~= _220_0.prefix)) then
4173
+ local prefix = _220_0.prefix
3734
4174
  local source0 = nil
3735
4175
  do
3736
- local _225_0 = table.remove(stack)
3737
- set_source_fields(_225_0)
3738
- source0 = _225_0
3739
- end
3740
- local list = utils.list(utils.sym(prefix, source0), v)
3741
- for k, v0 in pairs(source0) do
3742
- list[k] = v0
4176
+ local _221_0 = table.remove(stack)
4177
+ set_source_fields(_221_0)
4178
+ source0 = _221_0
3743
4179
  end
3744
- return dispatch(list)
3745
- elseif (nil ~= _224_0) then
3746
- local top = _224_0
3747
- whitespace_since_dispatch = false
3748
- return table.insert(top, v)
4180
+ local list = utils.list(utils.sym(prefix, source0), v0)
4181
+ return dispatch(utils.copy(source0, list))
4182
+ elseif (nil ~= _220_0) then
4183
+ local top = _220_0
4184
+ return table.insert(top, v0)
3749
4185
  end
3750
4186
  end
3751
4187
  local function badend()
3752
- local accum = utils.map(stack, "closer")
3753
- local _227_
4188
+ local closers = nil
4189
+ do
4190
+ local tbl_17_ = {}
4191
+ local i_18_ = #tbl_17_
4192
+ for _, _223_0 in ipairs(stack) do
4193
+ local _224_ = _223_0
4194
+ local closer = _224_["closer"]
4195
+ local val_19_ = closer
4196
+ if (nil ~= val_19_) then
4197
+ i_18_ = (i_18_ + 1)
4198
+ tbl_17_[i_18_] = val_19_
4199
+ end
4200
+ end
4201
+ closers = tbl_17_
4202
+ end
4203
+ local _226_
3754
4204
  if (#stack == 1) then
3755
- _227_ = ""
4205
+ _226_ = ""
3756
4206
  else
3757
- _227_ = "s"
4207
+ _226_ = "s"
3758
4208
  end
3759
- return parse_error(string.format("expected closing delimiter%s %s", _227_, string.char(unpack(accum))))
4209
+ return parse_error(string.format("expected closing delimiter%s %s", _226_, string.char(unpack(closers))))
3760
4210
  end
3761
4211
  local function skip_whitespace(b, close_table)
3762
4212
  if (b and whitespace_3f(b)) then
@@ -3774,11 +4224,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3774
4224
  end
3775
4225
  local function parse_comment(b, contents)
3776
4226
  if (b and (10 ~= b)) then
3777
- local function _230_()
4227
+ local function _229_()
3778
4228
  table.insert(contents, string.char(b))
3779
4229
  return contents
3780
4230
  end
3781
- return parse_comment(getb(), _230_())
4231
+ return parse_comment(getb(), _229_())
3782
4232
  elseif comments then
3783
4233
  ungetb(10)
3784
4234
  return dispatch(utils.comment(table.concat(contents), {filename = filename, line = line}))
@@ -3804,12 +4254,12 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3804
4254
  return dispatch(setmetatable(tbl, mt))
3805
4255
  end
3806
4256
  local function add_comment_at(comments0, index, node)
3807
- local _234_0 = comments0[index]
3808
- if (nil ~= _234_0) then
3809
- local existing = _234_0
4257
+ local _233_0 = comments0[index]
4258
+ if (nil ~= _233_0) then
4259
+ local existing = _233_0
3810
4260
  return table.insert(existing, node)
3811
4261
  else
3812
- local _ = _234_0
4262
+ local _ = _233_0
3813
4263
  comments0[index] = {node}
3814
4264
  return nil
3815
4265
  end
@@ -3888,16 +4338,16 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3888
4338
  end
3889
4339
  local state0 = nil
3890
4340
  do
3891
- local _245_0 = {state, b}
3892
- if ((_G.type(_245_0) == "table") and (_245_0[1] == "base") and (_245_0[2] == 92)) then
4341
+ local _244_0 = {state, b}
4342
+ if ((_G.type(_244_0) == "table") and (_244_0[1] == "base") and (_244_0[2] == 92)) then
3893
4343
  state0 = "backslash"
3894
- elseif ((_G.type(_245_0) == "table") and (_245_0[1] == "base") and (_245_0[2] == 34)) then
4344
+ elseif ((_G.type(_244_0) == "table") and (_244_0[1] == "base") and (_244_0[2] == 34)) then
3895
4345
  state0 = "done"
3896
- elseif ((_G.type(_245_0) == "table") and (_245_0[1] == "backslash") and (_245_0[2] == 10)) then
4346
+ elseif ((_G.type(_244_0) == "table") and (_244_0[1] == "backslash") and (_244_0[2] == 10)) then
3897
4347
  table.remove(chars, (#chars - 1))
3898
4348
  state0 = "base"
3899
4349
  else
3900
- local _ = _245_0
4350
+ local _ = _244_0
3901
4351
  state0 = "base"
3902
4352
  end
3903
4353
  end
@@ -3908,9 +4358,12 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3908
4358
  end
3909
4359
  end
3910
4360
  local function escape_char(c)
3911
- return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()]
4361
+ return ({nil, nil, nil, nil, nil, nil, "\\a", "\\b", "\\t", "\\n", "\\v", "\\f", "\\r"})[c:byte()]
3912
4362
  end
3913
- local function parse_string()
4363
+ local function parse_string(source0)
4364
+ if not whitespace_since_dispatch then
4365
+ utils.warn("expected whitespace before string", nil, filename, line)
4366
+ end
3914
4367
  table.insert(stack, {closer = 34})
3915
4368
  local chars = {"\""}
3916
4369
  if not parse_string_loop(chars, getb(), "base") then
@@ -3922,7 +4375,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3922
4375
  local _249_0 = (rawget(_G, "loadstring") or load)(("return " .. formatted))
3923
4376
  if (nil ~= _249_0) then
3924
4377
  local load_fn = _249_0
3925
- return dispatch(load_fn())
4378
+ return dispatch(load_fn(), source0, raw)
3926
4379
  elseif (_249_0 == nil) then
3927
4380
  return parse_error(("Invalid string: " .. raw))
3928
4381
  end
@@ -3930,14 +4383,16 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3930
4383
  local function parse_prefix(b)
3931
4384
  table.insert(stack, {bytestart = byteindex, col = (col - 1), filename = filename, line = line, prefix = prefixes[b]})
3932
4385
  local nextb = getb()
3933
- if (whitespace_3f(nextb) or (true == delims[nextb])) then
3934
- if (b ~= 35) then
3935
- parse_error("invalid whitespace after quoting prefix")
3936
- end
3937
- table.remove(stack)
3938
- dispatch(utils.sym("#"))
4386
+ local trailing_whitespace_3f = (whitespace_3f(nextb) or (true == delims[nextb]))
4387
+ if (trailing_whitespace_3f and (b ~= 35)) then
4388
+ parse_error("invalid whitespace after quoting prefix")
4389
+ end
4390
+ ungetb(nextb)
4391
+ if (trailing_whitespace_3f and (b == 35)) then
4392
+ local source0 = table.remove(stack)
4393
+ set_source_fields(source0)
4394
+ return dispatch(utils.sym("#", source0))
3939
4395
  end
3940
- return ungetb(nextb)
3941
4396
  end
3942
4397
  local function parse_sym_loop(chars, b)
3943
4398
  if (b and sym_char_3f(b)) then
@@ -3950,16 +4405,16 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3950
4405
  return chars
3951
4406
  end
3952
4407
  end
3953
- local function parse_number(rawstr)
4408
+ local function parse_number(rawstr, source0)
3954
4409
  local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", ""))
3955
4410
  if rawstr:match("^%d") then
3956
- dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\""))))
4411
+ dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\""))), source0, rawstr)
3957
4412
  return true
3958
4413
  else
3959
4414
  local _255_0 = tonumber(number_with_stripped_underscores)
3960
4415
  if (nil ~= _255_0) then
3961
4416
  local x = _255_0
3962
- dispatch(x)
4417
+ dispatch(x, source0, rawstr)
3963
4418
  return true
3964
4419
  else
3965
4420
  local _ = _255_0
@@ -3980,6 +4435,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3980
4435
  elseif rawstr:match(":.+[%.:]") then
3981
4436
  parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]"))
3982
4437
  end
4438
+ if not whitespace_since_dispatch then
4439
+ utils.warn("expected whitespace before token", nil, filename, line)
4440
+ end
3983
4441
  return rawstr
3984
4442
  end
3985
4443
  local function parse_sym(b)
@@ -3987,14 +4445,14 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
3987
4445
  local rawstr = table.concat(parse_sym_loop({string.char(b)}, getb()))
3988
4446
  set_source_fields(source0)
3989
4447
  if (rawstr == "true") then
3990
- return dispatch(true)
4448
+ return dispatch(true, source0)
3991
4449
  elseif (rawstr == "false") then
3992
- return dispatch(false)
4450
+ return dispatch(false, source0)
3993
4451
  elseif (rawstr == "...") then
3994
4452
  return dispatch(utils.varg(source0))
3995
4453
  elseif rawstr:match("^:.+$") then
3996
- return dispatch(rawstr:sub(2))
3997
- elseif not parse_number(rawstr) then
4454
+ return dispatch(rawstr:sub(2), source0, rawstr)
4455
+ elseif not parse_number(rawstr, source0) then
3998
4456
  return dispatch(utils.sym(check_malformed_sym(rawstr), source0))
3999
4457
  end
4000
4458
  end
@@ -4007,7 +4465,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
4007
4465
  elseif delims[b] then
4008
4466
  close_table(b)
4009
4467
  elseif (b == 34) then
4010
- parse_string()
4468
+ parse_string({bytestart = byteindex, col = col, filename = filename, line = line})
4011
4469
  elseif prefixes[b] then
4012
4470
  parse_prefix(b)
4013
4471
  elseif (sym_char_3f(b) or (b == string.byte("~"))) then
@@ -4025,11 +4483,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
4025
4483
  end
4026
4484
  return parse_loop(skip_whitespace(getb(), close_table))
4027
4485
  end
4028
- local function _262_()
4486
+ local function _263_()
4029
4487
  stack, line, byteindex, col, lastb = {}, 1, 0, 0, ((lastb ~= 10) and lastb)
4030
4488
  return nil
4031
4489
  end
4032
- return parse_stream, _262_
4490
+ return parse_stream, _263_
4033
4491
  end
4034
4492
  local function parser(stream_or_string, _3ffilename, _3foptions)
4035
4493
  local filename = (_3ffilename or "unknown")
@@ -4662,7 +5120,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...)
4662
5120
  end
4663
5121
  package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...)
4664
5122
  local view = require("fennel.view")
4665
- local version = "1.4.2"
5123
+ local version = "1.5.0"
4666
5124
  local function luajit_vm_3f()
4667
5125
  return ((nil ~= _G.jit) and (type(_G.jit) == "table") and (nil ~= _G.jit.on) and (nil ~= _G.jit.off) and (type(_G.jit.version_num) == "number"))
4668
5126
  end
@@ -4811,81 +5269,23 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
4811
5269
  end
4812
5270
  return stablenext, t, nil
4813
5271
  end
4814
- local function get_in(tbl, path, _3ffallback)
4815
- assert(("table" == type(tbl)), "get-in expects path to be a table")
4816
- if (0 == #path) then
4817
- return _3ffallback
4818
- else
4819
- local _123_0 = nil
4820
- do
4821
- local t = tbl
4822
- for _, k in ipairs(path) do
4823
- if (nil == t) then break end
4824
- local _124_0 = type(t)
4825
- if (_124_0 == "table") then
4826
- t = t[k]
4827
- else
4828
- t = nil
4829
- end
5272
+ local function get_in(tbl, path)
5273
+ if (nil ~= path[1]) then
5274
+ local t = tbl
5275
+ for _, k in ipairs(path) do
5276
+ if (nil == t) then break end
5277
+ if (type(t) == "table") then
5278
+ t = t[k]
5279
+ else
5280
+ t = nil
4830
5281
  end
4831
- _123_0 = t
4832
- end
4833
- if (nil ~= _123_0) then
4834
- local res = _123_0
4835
- return res
4836
- else
4837
- local _ = _123_0
4838
- return _3ffallback
4839
- end
4840
- end
4841
- end
4842
- local function map(t, f, _3fout)
4843
- local out = (_3fout or {})
4844
- local f0 = nil
4845
- if (type(f) == "function") then
4846
- f0 = f
4847
- else
4848
- local function _128_(_241)
4849
- return _241[f]
4850
5282
  end
4851
- f0 = _128_
5283
+ return t
4852
5284
  end
4853
- for _, x in ipairs(t) do
4854
- local _130_0 = f0(x)
4855
- if (nil ~= _130_0) then
4856
- local v = _130_0
4857
- table.insert(out, v)
4858
- end
4859
- end
4860
- return out
4861
5285
  end
4862
- local function kvmap(t, f, _3fout)
4863
- local out = (_3fout or {})
4864
- local f0 = nil
4865
- if (type(f) == "function") then
4866
- f0 = f
4867
- else
4868
- local function _132_(_241)
4869
- return _241[f]
4870
- end
4871
- f0 = _132_
4872
- end
4873
- for k, x in stablepairs(t) do
4874
- local _134_0, _135_0 = f0(k, x)
4875
- if ((nil ~= _134_0) and (nil ~= _135_0)) then
4876
- local key = _134_0
4877
- local value = _135_0
4878
- out[key] = value
4879
- elseif (nil ~= _134_0) then
4880
- local value = _134_0
4881
- table.insert(out, value)
4882
- end
4883
- end
4884
- return out
4885
- end
4886
- local function copy(from, _3fto)
5286
+ local function copy(_3ffrom, _3fto)
4887
5287
  local tbl_14_ = (_3fto or {})
4888
- for k, v in pairs((from or {})) do
5288
+ for k, v in pairs((_3ffrom or {})) do
4889
5289
  local k_15_, v_16_ = k, v
4890
5290
  if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
4891
5291
  tbl_14_[k_15_] = v_16_
@@ -4894,13 +5294,13 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
4894
5294
  return tbl_14_
4895
5295
  end
4896
5296
  local function member_3f(x, tbl, _3fn)
4897
- local _138_0 = tbl[(_3fn or 1)]
4898
- if (_138_0 == x) then
5297
+ local _126_0 = tbl[(_3fn or 1)]
5298
+ if (_126_0 == x) then
4899
5299
  return true
4900
- elseif (_138_0 == nil) then
5300
+ elseif (_126_0 == nil) then
4901
5301
  return nil
4902
5302
  else
4903
- local _ = _138_0
5303
+ local _ = _126_0
4904
5304
  return member_3f(x, tbl, ((_3fn or 1) + 1))
4905
5305
  end
4906
5306
  end
@@ -4935,9 +5335,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
4935
5335
  seen[next_state] = true
4936
5336
  return next_state, value
4937
5337
  else
4938
- local _141_0 = getmetatable(t)
4939
- if ((_G.type(_141_0) == "table") and true) then
4940
- local __index = _141_0.__index
5338
+ local _129_0 = getmetatable(t)
5339
+ if ((_G.type(_129_0) == "table") and true) then
5340
+ local __index = _129_0.__index
4941
5341
  if ("table" == type(__index)) then
4942
5342
  t = __index
4943
5343
  return allpairs_next(t)
@@ -4950,23 +5350,26 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
4950
5350
  local function deref(self)
4951
5351
  return self[1]
4952
5352
  end
4953
- local nil_sym = nil
4954
5353
  local function list__3estring(self, _3fview, _3foptions, _3findent)
4955
- local safe = {}
4956
- local view0 = nil
4957
- if _3fview then
4958
- local function _145_(_241)
4959
- return _3fview(_241, _3foptions, _3findent)
5354
+ local viewed = nil
5355
+ do
5356
+ local tbl_17_ = {}
5357
+ local i_18_ = #tbl_17_
5358
+ for i = 1, maxn(self) do
5359
+ local val_19_ = nil
5360
+ if _3fview then
5361
+ val_19_ = _3fview(self[i], _3foptions, _3findent)
5362
+ else
5363
+ val_19_ = view(self[i])
5364
+ end
5365
+ if (nil ~= val_19_) then
5366
+ i_18_ = (i_18_ + 1)
5367
+ tbl_17_[i_18_] = val_19_
5368
+ end
4960
5369
  end
4961
- view0 = _145_
4962
- else
4963
- view0 = view
4964
- end
4965
- local max = maxn(self)
4966
- for i = 1, max do
4967
- safe[i] = (((self[i] == nil) and nil_sym) or self[i])
5370
+ viewed = tbl_17_
4968
5371
  end
4969
- return ("(" .. table.concat(map(safe, view0), " ", 1, max) .. ")")
5372
+ return ("(" .. table.concat(viewed, " ") .. ")")
4970
5373
  end
4971
5374
  local function comment_view(c)
4972
5375
  return c, true
@@ -4979,19 +5382,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
4979
5382
  end
4980
5383
  local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref}
4981
5384
  local expr_mt = nil
4982
- local function _147_(x)
5385
+ local function _135_(x)
4983
5386
  return tostring(deref(x))
4984
5387
  end
4985
- expr_mt = {"EXPR", __tostring = _147_}
5388
+ expr_mt = {"EXPR", __tostring = _135_}
4986
5389
  local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring}
4987
5390
  local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref}
4988
5391
  local sequence_marker = {"SEQUENCE"}
4989
5392
  local varg_mt = {"VARARG", __fennelview = deref, __tostring = deref}
4990
5393
  local getenv = nil
4991
- local function _148_()
5394
+ local function _136_()
4992
5395
  return nil
4993
5396
  end
4994
- getenv = ((os and os.getenv) or _148_)
5397
+ getenv = ((os and os.getenv) or _136_)
4995
5398
  local function debug_on_3f(flag)
4996
5399
  local level = (getenv("FENNEL_DEBUG") or "")
4997
5400
  return ((level == "all") or level:find(flag))
@@ -5000,7 +5403,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5000
5403
  return setmetatable({...}, list_mt)
5001
5404
  end
5002
5405
  local function sym(str, _3fsource)
5003
- local _149_
5406
+ local _137_
5004
5407
  do
5005
5408
  local tbl_14_ = {str}
5006
5409
  for k, v in pairs((_3fsource or {})) do
@@ -5014,13 +5417,12 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5014
5417
  tbl_14_[k_15_] = v_16_
5015
5418
  end
5016
5419
  end
5017
- _149_ = tbl_14_
5420
+ _137_ = tbl_14_
5018
5421
  end
5019
- return setmetatable(_149_, symbol_mt)
5422
+ return setmetatable(_137_, symbol_mt)
5020
5423
  end
5021
- nil_sym = sym("nil")
5022
5424
  local function sequence(...)
5023
- local function _152_(seq, view0, inspector, indent)
5425
+ local function _140_(seq, view0, inspector, indent)
5024
5426
  local opts = nil
5025
5427
  do
5026
5428
  inspector["empty-as-sequence?"] = {after = inspector["empty-as-sequence?"], once = true}
@@ -5029,19 +5431,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5029
5431
  end
5030
5432
  return view0(seq, opts, indent)
5031
5433
  end
5032
- return setmetatable({...}, {__fennelview = _152_, sequence = sequence_marker})
5434
+ return setmetatable({...}, {__fennelview = _140_, sequence = sequence_marker})
5033
5435
  end
5034
5436
  local function expr(strcode, etype)
5035
5437
  return setmetatable({strcode, type = etype}, expr_mt)
5036
5438
  end
5037
5439
  local function comment_2a(contents, _3fsource)
5038
- local _153_ = (_3fsource or {})
5039
- local filename = _153_["filename"]
5040
- local line = _153_["line"]
5440
+ local _141_ = (_3fsource or {})
5441
+ local filename = _141_["filename"]
5442
+ local line = _141_["line"]
5041
5443
  return setmetatable({contents, filename = filename, line = line}, comment_mt)
5042
5444
  end
5043
5445
  local function varg(_3fsource)
5044
- local _154_
5446
+ local _142_
5045
5447
  do
5046
5448
  local tbl_14_ = {"..."}
5047
5449
  for k, v in pairs((_3fsource or {})) do
@@ -5055,9 +5457,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5055
5457
  tbl_14_[k_15_] = v_16_
5056
5458
  end
5057
5459
  end
5058
- _154_ = tbl_14_
5460
+ _142_ = tbl_14_
5059
5461
  end
5060
- return setmetatable(_154_, varg_mt)
5462
+ return setmetatable(_142_, varg_mt)
5061
5463
  end
5062
5464
  local function expr_3f(x)
5063
5465
  return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x)
@@ -5107,7 +5509,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5107
5509
  elseif (type(str) ~= "string") then
5108
5510
  return false
5109
5511
  else
5110
- local function _160_()
5512
+ local function _148_()
5111
5513
  local parts = {}
5112
5514
  for part in str:gmatch("[^%.%:]+[%.%:]?") do
5113
5515
  local last_char = part:sub(-1)
@@ -5122,19 +5524,22 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5122
5524
  end
5123
5525
  return (next(parts) and parts)
5124
5526
  end
5125
- return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte() ~= string.byte(":")) and (str:byte(-1) ~= string.byte(".")) and (str:byte(-1) ~= string.byte(":")) and _160_())
5527
+ return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte() ~= string.byte(":")) and (str:byte(-1) ~= string.byte(".")) and (str:byte(-1) ~= string.byte(":")) and _148_())
5126
5528
  end
5127
5529
  end
5530
+ local function call_of_3f(ast, callee)
5531
+ return (list_3f(ast) and sym_3f(ast[1], callee))
5532
+ end
5128
5533
  local function quoted_3f(symbol)
5129
5534
  return symbol.quoted
5130
5535
  end
5131
5536
  local function idempotent_expr_3f(x)
5132
5537
  local t = type(x)
5133
- return ((t == "string") or (t == "integer") or (t == "number") or (t == "boolean") or (sym_3f(x) and not multi_sym_3f(x)))
5538
+ return ((t == "string") or (t == "number") or (t == "boolean") or (sym_3f(x) and not multi_sym_3f(x)))
5134
5539
  end
5135
5540
  local function walk_tree(root, f, _3fcustom_iterator)
5136
5541
  local function walk(iterfn, parent, idx, node)
5137
- if f(idx, node, parent) then
5542
+ if (f(idx, node, parent) and not sym_3f(node)) then
5138
5543
  for k, v in iterfn(node) do
5139
5544
  walk(iterfn, node, k, v)
5140
5545
  end
@@ -5144,32 +5549,49 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5144
5549
  walk((_3fcustom_iterator or pairs), nil, nil, root)
5145
5550
  return root
5146
5551
  end
5552
+ local root = nil
5553
+ local function _153_()
5554
+ end
5555
+ root = {chunk = nil, options = nil, reset = _153_, scope = nil}
5556
+ root["set-reset"] = function(_154_0)
5557
+ local _155_ = _154_0
5558
+ local chunk = _155_["chunk"]
5559
+ local options = _155_["options"]
5560
+ local reset = _155_["reset"]
5561
+ local scope = _155_["scope"]
5562
+ root.reset = function()
5563
+ root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset
5564
+ return nil
5565
+ end
5566
+ return root.reset
5567
+ end
5147
5568
  local lua_keywords = {["and"] = true, ["break"] = true, ["do"] = true, ["else"] = true, ["elseif"] = true, ["end"] = true, ["false"] = true, ["for"] = true, ["function"] = true, ["goto"] = true, ["if"] = true, ["in"] = true, ["local"] = true, ["nil"] = true, ["not"] = true, ["or"] = true, ["repeat"] = true, ["return"] = true, ["then"] = true, ["true"] = true, ["until"] = true, ["while"] = true}
5569
+ local function lua_keyword_3f(str)
5570
+ local function _157_()
5571
+ local _156_0 = root.options
5572
+ if (nil ~= _156_0) then
5573
+ _156_0 = _156_0.keywords
5574
+ end
5575
+ if (nil ~= _156_0) then
5576
+ _156_0 = _156_0[str]
5577
+ end
5578
+ return _156_0
5579
+ end
5580
+ return (lua_keywords[str] or _157_())
5581
+ end
5148
5582
  local function valid_lua_identifier_3f(str)
5149
- return (str:match("^[%a_][%w_]*$") and not lua_keywords[str])
5583
+ return (str:match("^[%a_][%w_]*$") and not lua_keyword_3f(str))
5150
5584
  end
5151
5585
  local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env", "compilerEnv"}
5152
5586
  local function propagate_options(options, subopts)
5587
+ local tbl_14_ = subopts
5153
5588
  for _, name in ipairs(propagated_options) do
5154
- subopts[name] = options[name]
5155
- end
5156
- return subopts
5157
- end
5158
- local root = nil
5159
- local function _165_()
5160
- end
5161
- root = {chunk = nil, options = nil, reset = _165_, scope = nil}
5162
- root["set-reset"] = function(_166_0)
5163
- local _167_ = _166_0
5164
- local chunk = _167_["chunk"]
5165
- local options = _167_["options"]
5166
- local reset = _167_["reset"]
5167
- local scope = _167_["scope"]
5168
- root.reset = function()
5169
- root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset
5170
- return nil
5589
+ local k_15_, v_16_ = name, options[name]
5590
+ if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
5591
+ tbl_14_[k_15_] = v_16_
5592
+ end
5171
5593
  end
5172
- return root.reset
5594
+ return tbl_14_
5173
5595
  end
5174
5596
  local function ast_source(ast)
5175
5597
  if (table_3f(ast) or sequence_3f(ast)) then
@@ -5180,59 +5602,63 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5180
5602
  return {}
5181
5603
  end
5182
5604
  end
5183
- local function warn(msg, _3fast)
5605
+ local function warn(msg, _3fast, _3ffilename, _3fline)
5184
5606
  if (_G.io and _G.io.stderr) then
5185
5607
  local loc = nil
5186
5608
  do
5187
- local _169_0 = ast_source(_3fast)
5188
- if ((_G.type(_169_0) == "table") and (nil ~= _169_0.filename) and (nil ~= _169_0.line)) then
5189
- local filename = _169_0.filename
5190
- local line = _169_0.line
5609
+ local _162_0 = ast_source(_3fast)
5610
+ if ((_G.type(_162_0) == "table") and (nil ~= _162_0.filename) and (nil ~= _162_0.line)) then
5611
+ local filename = _162_0.filename
5612
+ local line = _162_0.line
5191
5613
  loc = (filename .. ":" .. line .. ": ")
5192
5614
  else
5193
- local _ = _169_0
5194
- loc = ""
5615
+ local _ = _162_0
5616
+ if (_3ffilename and _3fline) then
5617
+ loc = (_3ffilename .. ":" .. _3fline .. ": ")
5618
+ else
5619
+ loc = ""
5620
+ end
5195
5621
  end
5196
5622
  end
5197
5623
  return (_G.io.stderr):write(("--WARNING: %s%s\n"):format(loc, tostring(msg)))
5198
5624
  end
5199
5625
  end
5200
5626
  local warned = {}
5201
- local function check_plugin_version(_172_0)
5202
- local _173_ = _172_0
5203
- local plugin = _173_
5204
- local name = _173_["name"]
5205
- local versions = _173_["versions"]
5206
- if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not warned[plugin]) then
5627
+ local function check_plugin_version(_166_0)
5628
+ local _167_ = _166_0
5629
+ local plugin = _167_
5630
+ local name = _167_["name"]
5631
+ local versions = _167_["versions"]
5632
+ if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not (string_3f(versions) and version:find(versions)) and not warned[plugin]) then
5207
5633
  warned[plugin] = true
5208
5634
  return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version))
5209
5635
  end
5210
5636
  end
5211
5637
  local function hook_opts(event, _3foptions, ...)
5212
5638
  local plugins = nil
5213
- local function _176_(...)
5214
- local _175_0 = _3foptions
5215
- if (nil ~= _175_0) then
5216
- _175_0 = _175_0.plugins
5639
+ local function _170_(...)
5640
+ local _169_0 = _3foptions
5641
+ if (nil ~= _169_0) then
5642
+ _169_0 = _169_0.plugins
5217
5643
  end
5218
- return _175_0
5644
+ return _169_0
5219
5645
  end
5220
- local function _179_(...)
5221
- local _178_0 = root.options
5222
- if (nil ~= _178_0) then
5223
- _178_0 = _178_0.plugins
5646
+ local function _173_(...)
5647
+ local _172_0 = root.options
5648
+ if (nil ~= _172_0) then
5649
+ _172_0 = _172_0.plugins
5224
5650
  end
5225
- return _178_0
5651
+ return _172_0
5226
5652
  end
5227
- plugins = (_176_(...) or _179_(...))
5653
+ plugins = (_170_(...) or _173_(...))
5228
5654
  if plugins then
5229
5655
  local result = nil
5230
5656
  for _, plugin in ipairs(plugins) do
5231
- if result then break end
5657
+ if (nil ~= result) then break end
5232
5658
  check_plugin_version(plugin)
5233
- local _181_0 = plugin[event]
5234
- if (nil ~= _181_0) then
5235
- local f = _181_0
5659
+ local _175_0 = plugin[event]
5660
+ if (nil ~= _175_0) then
5661
+ local f = _175_0
5236
5662
  result = f(...)
5237
5663
  else
5238
5664
  result = nil
@@ -5244,7 +5670,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
5244
5670
  local function hook(event, ...)
5245
5671
  return hook_opts(event, root.options, ...)
5246
5672
  end
5247
- return {["ast-source"] = ast_source, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["fennel-module"] = nil, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempotent-expr?"] = idempotent_expr_3f, ["kv-table?"] = kv_table_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["runtime-version"] = runtime_version, ["sequence?"] = sequence_3f, ["string?"] = string_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, expr = expr, hook = hook, kvmap = kvmap, len = len, list = list, map = map, maxn = maxn, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg, version = version, warn = warn}
5673
+ return {["ast-source"] = ast_source, ["call-of?"] = call_of_3f, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["fennel-module"] = nil, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempotent-expr?"] = idempotent_expr_3f, ["kv-table?"] = kv_table_3f, ["list?"] = list_3f, ["lua-keyword?"] = lua_keyword_3f, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["runtime-version"] = runtime_version, ["sequence?"] = sequence_3f, ["string?"] = string_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, expr = expr, hook = hook, len = len, list = list, maxn = maxn, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg, version = version, warn = warn}
5248
5674
  end
5249
5675
  utils = require("fennel.utils")
5250
5676
  local parser = require("fennel.parser")
@@ -5281,14 +5707,14 @@ local function eval(str, _3foptions, ...)
5281
5707
  local env = eval_env(opts.env, opts)
5282
5708
  local lua_source = compiler["compile-string"](str, opts)
5283
5709
  local loader = nil
5284
- local function _750_(...)
5710
+ local function _814_(...)
5285
5711
  if opts.filename then
5286
5712
  return ("@" .. opts.filename)
5287
5713
  else
5288
5714
  return str
5289
5715
  end
5290
5716
  end
5291
- loader = specials["load-code"](lua_source, env, _750_(...))
5717
+ loader = specials["load-code"](lua_source, env, _814_(...))
5292
5718
  opts.filename = nil
5293
5719
  return loader(...)
5294
5720
  end
@@ -5314,10 +5740,10 @@ local function syntax()
5314
5740
  out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true}
5315
5741
  end
5316
5742
  for k, v in pairs(_G) do
5317
- local _751_0 = type(v)
5318
- if (_751_0 == "function") then
5743
+ local _815_0 = type(v)
5744
+ if (_815_0 == "function") then
5319
5745
  out[k] = {["function?"] = true, ["global?"] = true}
5320
- elseif (_751_0 == "table") then
5746
+ elseif (_815_0 == "table") then
5321
5747
  if not k:find("^_") then
5322
5748
  for k2, v2 in pairs(v) do
5323
5749
  if ("function" == type(v2)) then
@@ -5330,7 +5756,7 @@ local function syntax()
5330
5756
  end
5331
5757
  return out
5332
5758
  end
5333
- local mod = {["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["multi-sym?"] = utils["multi-sym?"], ["runtime-version"] = utils["runtime-version"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, runtimeVersion = utils["runtime-version"], scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = utils.version, view = view}
5759
+ local mod = {["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["multi-sym?"] = utils["multi-sym?"], ["runtime-version"] = utils["runtime-version"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, getinfo = compiler.getinfo, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, runtimeVersion = utils["runtime-version"], scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = utils.version, view = view}
5334
5760
  mod.install = function(_3fopts)
5335
5761
  table.insert((package.searchers or package.loaders), specials["make-searcher"](_3fopts))
5336
5762
  return mod
@@ -5339,18 +5765,18 @@ utils["fennel-module"] = mod
5339
5765
  do
5340
5766
  local module_name = "fennel.macros"
5341
5767
  local _ = nil
5342
- local function _755_()
5768
+ local function _819_()
5343
5769
  return mod
5344
5770
  end
5345
- package.preload[module_name] = _755_
5771
+ package.preload[module_name] = _819_
5346
5772
  _ = nil
5347
5773
  local env = nil
5348
5774
  do
5349
- local _756_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
5350
- _756_0["utils"] = utils
5351
- _756_0["fennel"] = mod
5352
- _756_0["get-function-metadata"] = specials["get-function-metadata"]
5353
- env = _756_0
5775
+ local _820_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
5776
+ _820_0["utils"] = utils
5777
+ _820_0["fennel"] = mod
5778
+ _820_0["get-function-metadata"] = specials["get-function-metadata"]
5779
+ env = _820_0
5354
5780
  end
5355
5781
  local built_ins = eval([===[;; fennel-ls: macro-file
5356
5782
 
@@ -5389,26 +5815,28 @@ do
5389
5815
  Same as -> except will short-circuit with nil when it encounters a nil value."
5390
5816
  (if (= nil ?e)
5391
5817
  val
5392
- (let [el (if (list? ?e) (copy ?e) (list ?e))
5393
- tmp (gensym)]
5394
- (table.insert el 2 tmp)
5395
- `(let [,tmp ,val]
5396
- (if (not= nil ,tmp)
5397
- (-?> ,el ,...)
5398
- ,tmp)))))
5818
+ (not (utils.idempotent-expr? val))
5819
+ ;; try again, but with an eval-safe val
5820
+ `(let [tmp# ,val]
5821
+ (-?> tmp# ,?e ,...))
5822
+ (let [call (if (list? ?e) (copy ?e) (list ?e))]
5823
+ (table.insert call 2 val)
5824
+ `(if (not= nil ,val)
5825
+ ,(-?>* call ...)))))
5399
5826
 
5400
5827
  (fn -?>>* [val ?e ...]
5401
5828
  "Nil-safe thread-last macro.
5402
5829
  Same as ->> except will short-circuit with nil when it encounters a nil value."
5403
5830
  (if (= nil ?e)
5404
5831
  val
5405
- (let [el (if (list? ?e) (copy ?e) (list ?e))
5406
- tmp (gensym)]
5407
- (table.insert el tmp)
5408
- `(let [,tmp ,val]
5409
- (if (not= ,tmp nil)
5410
- (-?>> ,el ,...)
5411
- ,tmp)))))
5832
+ (not (utils.idempotent-expr? val))
5833
+ ;; try again, but with an eval-safe val
5834
+ `(let [tmp# ,val]
5835
+ (-?>> tmp# ,?e ,...))
5836
+ (let [call (if (list? ?e) (copy ?e) (list ?e))]
5837
+ (table.insert call val)
5838
+ `(if (not= ,val nil)
5839
+ ,(-?>>* call ...)))))
5412
5840
 
5413
5841
  (fn ?dot [tbl ...]
5414
5842
  "Nil-safe table look up.
@@ -5418,26 +5846,26 @@ do
5418
5846
  lookups `(do
5419
5847
  (var ,head ,tbl)
5420
5848
  ,head)]
5421
- (each [_ k (ipairs [...])]
5849
+ (each [i k (ipairs [...])]
5422
5850
  ;; Kinda gnarly to reassign in place like this, but it emits the best lua.
5423
5851
  ;; With this impl, it emits a flat, concise, and readable set of ifs
5424
- (table.insert lookups (# lookups) `(if (not= nil ,head)
5425
- (set ,head (. ,head ,k)))))
5852
+ (table.insert lookups (+ i 2)
5853
+ `(if (not= nil ,head) (set ,head (. ,head ,k)))))
5426
5854
  lookups))
5427
5855
 
5428
5856
  (fn doto* [val ...]
5429
5857
  "Evaluate val and splice it into the first argument of subsequent forms."
5430
5858
  (assert (not= val nil) "missing subject")
5431
- (let [rebind? (or (not (sym? val))
5432
- (multi-sym? val))
5433
- name (if rebind? (gensym) val)
5434
- form (if rebind? `(let [,name ,val]) `(do))]
5435
- (each [_ elt (ipairs [...])]
5436
- (let [elt (if (list? elt) (copy elt) (list elt))]
5437
- (table.insert elt 2 name)
5438
- (table.insert form elt)))
5439
- (table.insert form name)
5440
- form))
5859
+ (if (not (utils.idempotent-expr? val))
5860
+ `(let [tmp# ,val]
5861
+ (doto tmp# ,...))
5862
+ (let [form `(do)]
5863
+ (each [_ elt (ipairs [...])]
5864
+ (let [elt (if (list? elt) (copy elt) (list elt))]
5865
+ (table.insert elt 2 val)
5866
+ (table.insert form elt)))
5867
+ (table.insert form val)
5868
+ form)))
5441
5869
 
5442
5870
  (fn when* [condition body1 ...]
5443
5871
  "Evaluate body for side-effects only when condition is truthy."
@@ -5455,7 +5883,7 @@ do
5455
5883
  ,...)
5456
5884
  closer `(fn close-handlers# [ok# ...]
5457
5885
  (if ok# ... (error ... 0)))
5458
- traceback `(. (or (. package.loaded ,(fennel-module-name)) debug)
5886
+ traceback `(. (or (. package.loaded ,(fennel-module-name)) _G.debug {})
5459
5887
  :traceback)]
5460
5888
  (for [i 1 (length closable-bindings) 2]
5461
5889
  (assert (sym? (. closable-bindings i))
@@ -5499,6 +5927,7 @@ do
5499
5927
  (assert (not= nil key-expr) "expected key and value expression")
5500
5928
  (assert (= nil ...)
5501
5929
  "expected 1 or 2 body expressions; wrap multiple expressions with do")
5930
+ (assert (or value-expr (list? key-expr)) "need key and value")
5502
5931
  (let [kv-expr (if (= nil value-expr) key-expr `(values ,key-expr ,value-expr))
5503
5932
  (into iter) (extract-into iter-tbl)]
5504
5933
  `(let [tbl# ,into]
@@ -5612,17 +6041,13 @@ do
5612
6041
  numerical range like `for` rather than an iterator."
5613
6042
  (accumulate-impl true iter-tbl body ...))
5614
6043
 
5615
- (fn double-eval-safe? [x type]
5616
- (or (= :number type) (= :string type) (= :boolean type)
5617
- (and (sym? x) (not (multi-sym? x)))))
5618
-
5619
6044
  (fn partial* [f ...]
5620
6045
  "Return a function with all arguments partially applied to f."
5621
6046
  (assert f "expected a function to partially apply")
5622
6047
  (let [bindings []
5623
6048
  args []]
5624
6049
  (each [_ arg (ipairs [...])]
5625
- (if (double-eval-safe? arg (type arg))
6050
+ (if (utils.idempotent-expr? arg)
5626
6051
  (table.insert args arg)
5627
6052
  (let [name (gensym)]
5628
6053
  (table.insert bindings name)
@@ -5631,46 +6056,19 @@ do
5631
6056
  (let [body (list f (unpack args))]
5632
6057
  (table.insert body _VARARG)
5633
6058
  ;; only use the extra let if we need double-eval protection
5634
- (if (= 0 (length bindings))
6059
+ (if (= nil (. bindings 1))
5635
6060
  `(fn [,_VARARG] ,body)
5636
6061
  `(let ,bindings
5637
6062
  (fn [,_VARARG] ,body))))))
5638
6063
 
5639
6064
  (fn pick-args* [n f]
5640
- "Create a function of arity n that applies its arguments to f.
5641
-
5642
- For example,
5643
- (pick-args 2 func)
5644
- expands to
5645
- (fn [_0_ _1_] (func _0_ _1_))"
6065
+ "Create a function of arity n that applies its arguments to f. Deprecated."
5646
6066
  (if (and _G.io _G.io.stderr)
5647
6067
  (_G.io.stderr:write
5648
6068
  "-- WARNING: pick-args is deprecated and will be removed in the future.\n"))
5649
- (assert (and (= (type n) :number) (= n (math.floor n)) (<= 0 n))
5650
- (.. "Expected n to be an integer literal >= 0, got " (tostring n)))
5651
6069
  (let [bindings []]
5652
- (for [i 1 n]
5653
- (tset bindings i (gensym)))
5654
- `(fn ,bindings
5655
- (,f ,(unpack bindings)))))
5656
-
5657
- (fn pick-values* [n ...]
5658
- "Evaluate to exactly n values.
5659
-
5660
- For example,
5661
- (pick-values 2 ...)
5662
- expands to
5663
- (let [(_0_ _1_) ...]
5664
- (values _0_ _1_))"
5665
- (assert (and (= :number (type n)) (<= 0 n) (= n (math.floor n)))
5666
- (.. "Expected n to be an integer >= 0, got " (tostring n)))
5667
- (let [let-syms (list)
5668
- let-values (if (= 1 (select "#" ...)) ... `(values ,...))]
5669
- (for [_ 1 n]
5670
- (table.insert let-syms (gensym)))
5671
- (if (= n 0) `(values)
5672
- `(let [,let-syms ,let-values]
5673
- (values ,(unpack let-syms))))))
6070
+ (for [i 1 n] (tset bindings i (gensym)))
6071
+ `(fn ,bindings (,f ,(unpack bindings)))))
5674
6072
 
5675
6073
  (fn lambda* [...]
5676
6074
  "Function literal with nil-checked arguments.
@@ -5681,14 +6079,14 @@ do
5681
6079
  has-internal-name? (sym? (. args 1))
5682
6080
  arglist (if has-internal-name? (. args 2) (. args 1))
5683
6081
  metadata-position (if has-internal-name? 3 2)
5684
- (f-metadata check-position) (get-function-metadata [:lambda ...] arglist
5685
- metadata-position)
6082
+ (_ check-position) (get-function-metadata [:lambda ...] arglist
6083
+ metadata-position)
5686
6084
  empty-body? (< args-len check-position)]
5687
6085
  (fn check! [a]
5688
6086
  (if (table? a)
5689
6087
  (each [_ a (pairs a)] (check! a))
5690
6088
  (let [as (tostring a)]
5691
- (and (not (as:match "^?")) (not= as "&") (not= as "_")
6089
+ (and (not (as:find "^?")) (not= as "&") (not (as:find "^_"))
5692
6090
  (not= as "...") (not= as "&as")))
5693
6091
  (table.insert args check-position
5694
6092
  `(_G.assert (not= nil ,a)
@@ -5712,7 +6110,9 @@ do
5712
6110
  "Print the resulting form after performing macroexpansion.
5713
6111
  With a second argument, returns expanded form as a string instead of printing."
5714
6112
  (let [handle (if return? `do `print)]
5715
- `(,handle ,(view (macroexpand form _SCOPE)))))
6113
+ ;; TODO: Provide a helpful compiler error in the unlikely edge case of an
6114
+ ;; infinite AST instead of the current "silently expand until max depth"
6115
+ `(,handle ,(view (macroexpand form _SCOPE) {:detect-cycles? false}))))
5716
6116
 
5717
6117
  (fn import-macros* [binding1 module-name1 ...]
5718
6118
  "Bind a table of macros from each macro module according to a binding form.
@@ -5790,7 +6190,6 @@ do
5790
6190
  :lambda lambda*
5791
6191
  :λ lambda*
5792
6192
  :pick-args pick-args*
5793
- :pick-values pick-values*
5794
6193
  :macro macro*
5795
6194
  :macrodebug macrodebug*
5796
6195
  :import-macros import-macros*
@@ -5809,6 +6208,10 @@ do
5809
6208
 
5810
6209
  (fn copy [t] (collect [k v (pairs t)] k v))
5811
6210
 
6211
+ (fn double-eval-safe? [x type]
6212
+ (or (= :number type) (= :string type) (= :boolean type)
6213
+ (and (sym? x) (not (multi-sym? x)))))
6214
+
5812
6215
  (fn with [opts k]
5813
6216
  (doto (copy opts) (tset k true)))
5814
6217
 
@@ -5863,13 +6266,13 @@ do
5863
6266
  (values condition bindings)))
5864
6267
 
5865
6268
  (fn case-guard [vals condition guards unifications case-pattern opts]
5866
- (if (= 0 (length guards))
5867
- (case-pattern vals condition unifications opts)
6269
+ (if (. guards 1)
5868
6270
  (let [(pcondition bindings) (case-pattern vals condition unifications opts)
5869
6271
  condition `(and ,(unpack guards))]
5870
6272
  (values `(and ,pcondition
5871
6273
  (let ,bindings
5872
- ,condition)) bindings))))
6274
+ ,condition)) bindings))
6275
+ (case-pattern vals condition unifications opts)))
5873
6276
 
5874
6277
  (fn symbols-in-pattern [pattern]
5875
6278
  "gives the set of symbols inside a pattern"
@@ -5919,16 +6322,14 @@ do
5919
6322
  (fn case-or [vals pattern guards unifications case-pattern opts]
5920
6323
  (let [pattern [(unpack pattern 2)]
5921
6324
  bindings (symbols-in-every-pattern pattern opts.infer-unification?)]
5922
- (if (= 0 (length bindings))
5923
- ;; no bindings special case generates simple code
5924
- (let [condition
5925
- (icollect [_ subpattern (ipairs pattern) &into `(or)]
5926
- (case-pattern vals subpattern unifications opts))]
5927
- (values
5928
- (if (= 0 (length guards))
5929
- condition
5930
- `(and ,condition ,(unpack guards)))
5931
- []))
6325
+ (if (= nil (. bindings 1))
6326
+ ;; no bindings special case generates simple code
6327
+ (let [condition (icollect [_ subpattern (ipairs pattern) &into `(or)]
6328
+ (case-pattern vals subpattern unifications opts))]
6329
+ (values (if (. guards 1)
6330
+ `(and ,condition ,(unpack guards))
6331
+ condition)
6332
+ []))
5932
6333
  ;; case with bindings is handled specially, and returns three values instead of two
5933
6334
  (let [matched? (gensym :matched?)
5934
6335
  bindings-mangled (icollect [_ binding (ipairs bindings)]
@@ -6086,6 +6487,19 @@ do
6086
6487
  _ pattern (ipairs patterns)]
6087
6488
  (math.max longest (count-case-multival pattern)))))
6088
6489
 
6490
+ (fn maybe-optimize-table [val clauses]
6491
+ (if (faccumulate [all (sequence? val) i 1 (length clauses) 2 &until (not all)]
6492
+ (and (sequence? (. clauses i))
6493
+ (accumulate [all2 (next (. clauses i))
6494
+ _ d (ipairs (. clauses i)) &until (not all2)]
6495
+ (and all2 (or (not (sym? d)) (not (: (tostring d) :find "^&")))))))
6496
+ (values `(values ,(unpack val))
6497
+ (fcollect [i 1 (length clauses)]
6498
+ (if (= 1 (% i 2))
6499
+ (list (unpack (. clauses i)))
6500
+ (. clauses i))))
6501
+ (values val clauses)))
6502
+
6089
6503
  (fn case-impl [match? val ...]
6090
6504
  "The shared implementation of case and match."
6091
6505
  (assert (not= val nil) "missing subject")
@@ -6093,9 +6507,9 @@ do
6093
6507
  "expected even number of pattern/body pairs")
6094
6508
  (assert (not= 0 (select :# ...))
6095
6509
  "expected at least one pattern/body pair")
6096
- (let [clauses [...]
6510
+ (let [(val clauses) (maybe-optimize-table val [...])
6097
6511
  vals-count (case-count-syms clauses)
6098
- skips-multiple-eval-protection? (and (= vals-count 1) (sym? val) (not (multi-sym? val)))]
6512
+ skips-multiple-eval-protection? (and (= vals-count 1) (double-eval-safe? val))]
6099
6513
  (if skips-multiple-eval-protection?
6100
6514
  (case-condition (list val) clauses match?)
6101
6515
  ;; protect against multiple evaluation of the value, bind against as
@@ -6111,10 +6525,7 @@ do
6111
6525
  (case data-expression
6112
6526
  pattern body
6113
6527
  (where pattern guards*) body
6114
- (or pattern patterns*) body
6115
- (where (or pattern patterns*) guards*) body
6116
- ;; legacy:
6117
- (pattern ? guards*) body)"
6528
+ (where (or pattern patterns*) guards*) body)"
6118
6529
  (case-impl false val ...))
6119
6530
 
6120
6531
  (fn match* [val ...]
@@ -6126,10 +6537,7 @@ do
6126
6537
  (match data-expression
6127
6538
  pattern body
6128
6539
  (where pattern guards*) body
6129
- (or pattern patterns*) body
6130
- (where (or pattern patterns*) guards*) body
6131
- ;; legacy:
6132
- (pattern ? guards*) body)"
6540
+ (where (or pattern patterns*) guards*) body)"
6133
6541
  (case-impl true val ...))
6134
6542
 
6135
6543
  (fn case-try-step [how expr else pattern body ...]