forked from bakpakin/Fennel
-
Notifications
You must be signed in to change notification settings - Fork 0
/
fennel.lua
1751 lines (1634 loc) · 58.2 KB
/
fennel.lua
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
--[[
Copyright (c) 2016-2018 Calvin Rose and contributors
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
]]
-- Make global variables local.
local setmetatable = setmetatable
local getmetatable = getmetatable
local type = type
local assert = assert
local pairs = pairs
local ipairs = ipairs
local tostring = tostring
local unpack = unpack or table.unpack
--
-- Main Types and support functions
--
local function deref(self) return self[1] end
local SYMBOL_MT = { 'SYMBOL', __tostring = deref }
local EXPR_MT = { 'EXPR', __tostring = deref }
local VARARG = setmetatable({ '...' }, { 'VARARG', __tostring = deref })
local LIST_MT = { 'LIST',
__tostring = function (self)
local strs = {}
for _, s in ipairs(self) do
table.insert(strs, tostring(s))
end
return '(' .. table.concat(strs, ', ', 1, #self) .. ')'
end
}
-- Load code with an environment in all recent Lua versions
local function loadCode(code, environment, filename)
environment = environment or _ENV or _G
if setfenv and loadstring then
local f = assert(loadstring(code, filename))
setfenv(f, environment)
return f
else
return assert(load(code, filename, "t", environment))
end
end
-- Create a new list
local function list(...)
return setmetatable({...}, LIST_MT)
end
-- Create a new symbol
local function sym(str, scope, meta)
local s = {str, scope = scope}
if meta then
for k, v in pairs(meta) do
if type(k) == 'string' then s[k] = v end
end
end
return setmetatable(s, SYMBOL_MT)
end
-- Create a new expr
-- etype should be one of
-- "literal", -- literals like numbers, strings, nil, true, false
-- "expression", -- Complex strings of Lua code, may have side effects, etc, but is an expression
-- "statement", -- Same as expression, but is also a valid statement (function calls).
-- "vargs", -- varargs symbol
-- "sym", -- symbol reference
local function expr(strcode, etype)
return setmetatable({ strcode, type = etype }, EXPR_MT)
end
local function varg()
return VARARG
end
local function isVarg(x)
return x == VARARG and x
end
-- Checks if an object is a List. Returns the object if is a List.
local function isList(x)
return type(x) == 'table' and getmetatable(x) == LIST_MT and x
end
-- Checks if an object is a symbol. Returns the object if it is a symbol.
local function isSym(x)
return type(x) == 'table' and getmetatable(x) == SYMBOL_MT and x
end
-- Checks if an object any kind of table, EXCEPT list or symbol
local function isTable(x)
return type(x) == 'table' and
x ~= VARARG and
getmetatable(x) ~= LIST_MT and getmetatable(x) ~= SYMBOL_MT and x
end
--
-- Parser
--
-- Convert a stream of chunks to a stream of bytes.
-- Also returns a second function to clear the buffer in the byte stream
local function granulate(getchunk)
local c = ''
local index = 1
local done = false
return function ()
if done then return nil end
if index <= #c then
local b = c:byte(index)
index = index + 1
return b
else
c = getchunk()
if not c or c == '' then
done = true
return nil
end
index = 2
return c:byte(1)
end
end, function ()
c = ''
end
end
-- Convert a string into a stream of bytes
local function stringStream(str)
local index = 1
return function()
local r = str:byte(index)
index = index + 1
return r
end
end
-- Table of delimiter bytes - (, ), [, ], {, }
-- Opener keys have closer as the value, and closers keys
-- have true as their value.
local delims = {
[40] = 41, -- (
[41] = true, -- )
[91] = 93, -- [
[93] = true, -- ]
[123] = 125, -- {
[125] = true -- }
}
local function iswhitespace(b)
return b == 32 or (b >= 9 and b <= 13) or b == 44
end
local function issymbolchar(b)
return b > 32 and
not delims[b] and
b ~= 127 and
b ~= 34 and
b ~= 39 and
b ~= 59 and
b ~= 44
end
-- Parse one value given a function that
-- returns sequential bytes. Will throw an error as soon
-- as possible without getting more bytes on bad input. Returns
-- if a value was read, and then the value read. Will return nil
-- when input stream is finished.
local function parser(getbyte, filename)
-- Stack of unfinished values
local stack = {}
-- Provide one character buffer and keep
-- track of current line and byte index
local line = 1
local byteindex = 0
local lastb
local function ungetb(ub)
if ub == 10 then line = line - 1 end
byteindex = byteindex - 1
lastb = ub
end
local function getb()
local r
if lastb then
r, lastb = lastb, nil
else
r = getbyte()
end
byteindex = byteindex + 1
if r == 10 then line = line + 1 end
return r
end
-- Parse stream
return function ()
-- Dispatch when we complete a value
local done, retval
local function dispatch(v)
if #stack == 0 then
retval = v
done = true
else
table.insert(stack[#stack], v)
end
end
-- The main parse loop
repeat
local b
-- Skip whitespace
repeat
b = getb()
until not b or not iswhitespace(b)
if not b then
if #stack > 0 then error 'unexpected end of source' end
return nil
end
if b == 59 then -- ; Comment
repeat
b = getb()
until not b or b == 10 -- newline
elseif type(delims[b]) == 'number' then -- Opening delimiter
table.insert(stack, setmetatable({
closer = delims[b],
line = line,
filename = filename,
bytestart = byteindex
}, LIST_MT))
elseif delims[b] then -- Closing delimiter
if #stack == 0 then error 'unexpected closing delimiter' end
local last = stack[#stack]
local val
if last.closer ~= b then
error('unexpected delimiter ' .. string.char(b) .. ', expected ' .. string.char(last.closer))
end
last.byteend = byteindex -- Set closing byte index
if b == 41 then -- )
val = last
elseif b == 93 then -- ]
val = {}
for i = 1, #last do
val[i] = last[i]
end
else -- }
if #last % 2 ~= 0 then
error 'expected even number of values in table literal'
end
val = {}
for i = 1, #last, 2 do
val[last[i]] = last[i + 1]
end
end
stack[#stack] = nil
dispatch(val)
elseif b == 34 or b == 39 then -- Quoted string
local start = b
local state = "base"
local chars = {start}
repeat
b = getb()
chars[#chars + 1] = b
if state == "base" then
if b == 92 then
state = "backslash"
elseif b == start then
state = "done"
end
else
-- state == "backslash"
state = "base"
end
until not b or (state == "done")
if not b then error 'unexpected end of source' end
local raw = string.char(unpack(chars))
local loadFn = loadCode(('return %s'):format(raw), nil, filename)
dispatch(loadFn())
else -- Try symbol
local chars = {}
local bytestart = byteindex
repeat
chars[#chars + 1] = b
b = getb()
until not b or not issymbolchar(b)
if b then ungetb(b) end
local rawstr = string.char(unpack(chars))
if rawstr == 'true' then dispatch(true)
elseif rawstr == 'false' then dispatch(false)
elseif rawstr == '...' then dispatch(VARARG)
elseif rawstr:match('^:.+$') then -- keyword style strings
dispatch(rawstr:sub(2))
else
local forceNumber = rawstr:match('^%d')
local x
if forceNumber then
x = tonumber(rawstr) or error('could not read token "' .. rawstr .. '"')
else
x = tonumber(rawstr) or sym(rawstr, nil, {
line = line,
filename = filename,
bytestart = bytestart,
byteend = byteindex
})
end
dispatch(x)
end
end
until done
return true, retval
end
end
--
-- Compilation
--
-- Create a new Scope, optionally under a parent scope. Scopes are compile time constructs
-- that are responsible for keeping track of local variables, name mangling, and macros.
-- They are accessible to user code via the '*compiler' special form (may change). They
-- use metatables to implement nesting via inheritance.
local function makeScope(parent)
return {
unmanglings = setmetatable({}, {
__index = parent and parent.unmanglings
}),
manglings = setmetatable({}, {
__index = parent and parent.manglings
}),
specials = setmetatable({}, {
__index = parent and parent.specials
}),
symmeta = setmetatable({}, {
__index = parent and parent.symmeta
}),
parent = parent,
vararg = parent and parent.vararg,
depth = parent and ((parent.depth or 0) + 1) or 0
}
end
-- Assert a condition and raise a compile error with line numbers. The ast arg
-- should be unmodified so that its first element is the form being called.
local function assertCompile(condition, msg, ast)
-- if we use regular `assert' we can't provide the `level' argument of zero
if not condition then
error(string.format("Compile error in '%s' %s:%s: %s", ast[1][1],
ast.filename or "unknown", ast.line or '?', msg), 0)
end
return condition
end
local GLOBAL_SCOPE = makeScope()
GLOBAL_SCOPE.vararg = true
local SPECIALS = GLOBAL_SCOPE.specials
local COMPILER_SCOPE = makeScope(GLOBAL_SCOPE)
local luaKeywords = {
'and', 'break', 'do', 'else', 'elseif', 'end', 'false', 'for', 'function',
'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return', 'then', 'true',
'until', 'while'
}
for i, v in ipairs(luaKeywords) do
luaKeywords[v] = i
end
local function isValidLuaIdentifier(str)
return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
end
-- Allow printing a string to Lua, also keep as 1 line.
local serializeSubst = {
['\a'] = '\\a',
['\b'] = '\\b',
['\f'] = '\\f',
['\n'] = 'n',
['\t'] = '\\t',
['\v'] = '\\v'
}
local function serializeString(str)
local s = ("%q"):format(str)
s = s:gsub('.', serializeSubst):gsub("[\128-\255]", function(c)
return "\\" .. c:byte()
end)
return s
end
-- A multi symbol is a symbol that is actually composed of
-- two or more symbols using the dot syntax. The main differences
-- from normal symbols is that they cannot be declared local, and
-- they may have side effects on invocation (metatables)
local function isMultiSym(str)
if type(str) ~= 'string' then return end
local parts = {}
for part in str:gmatch('[^%.]+') do
parts[#parts + 1] = part
end
return #parts > 0 and
str:match('%.') and
(not str:match('%.%.')) and
str:byte() ~= string.byte '.' and
str:byte(-1) ~= string.byte '.' and
parts
end
-- Mangler for global symbols. Does not protect against collisions,
-- but makes them unlikely. This is the mangling that is exposed to
-- to the world.
local function globalMangling(str)
if isValidLuaIdentifier(str) then
return str
end
-- Use underscore as escape character
return '__fnl_global__' .. str:gsub('[^%w]', function (c)
return ('_%02x'):format(c:byte())
end)
end
-- Reverse a global mangling. Takes a Lua identifier and
-- returns the fennel symbol string that created it.
local function globalUnmangling(identifier)
local rest = identifier:match('^__fnl_global__(.*)$')
if rest then
return rest:gsub('_[%da-f][%da-f]', function (code)
return string.char(tonumber(code:sub(2), 16))
end)
else
return identifier
end
end
-- Creates a symbol from a string by mangling it.
-- ensures that the generated symbol is unique
-- if the input string is unique in the scope.
local function localMangling(str, scope)
if scope.manglings[str] then
return scope.manglings[str]
end
local append = 0
local mangling = str
if isMultiSym(str) then error 'did not expect a multi symbol' end
-- Mapping mangling to a valid Lua identifier
if luaKeywords[mangling] or mangling:match('^%d') then
mangling = '_' .. mangling
end
mangling = mangling:gsub('-', '_')
mangling = mangling:gsub('[^%w_]', function (c)
return ('_%02x'):format(c:byte())
end)
local raw = mangling
while scope.unmanglings[mangling] do
mangling = raw .. append
append = append + 1
end
scope.unmanglings[mangling] = str
scope.manglings[str] = mangling
return mangling
end
-- Combine parts of a symbol
local function combineParts(parts, scope)
local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
for i = 2, #parts do
if isValidLuaIdentifier(parts[i]) then
ret = ret .. '.' .. parts[i]
else
ret = ret .. '[' .. serializeString(parts[i]) .. ']'
end
end
return ret
end
-- Generates a unique symbol in the scope.
local function gensym(scope)
local mangling
local append = 0
repeat
mangling = '_' .. append .. '_'
append = append + 1
until not scope.unmanglings[mangling]
scope.unmanglings[mangling] = true
return mangling
end
-- Declare a local symbol
local function declareLocal(symbol, meta, scope, ast)
local name = symbol[1]
assertCompile(not isMultiSym(name), "did not expect mutltisym", ast)
local mangling = localMangling(name, scope)
scope.symmeta[name] = meta
return mangling
end
-- Convert symbol to Lua code. Will only work for local symbols
-- if they have already been declared via declareLocal
local function symbolToExpression(symbol, scope)
local name = symbol[1]
local parts = isMultiSym(name) or {name}
local etype = (#parts > 1) and "expression" or "sym"
return expr(combineParts(parts, scope), etype)
end
-- Emit Lua code
local function emit(chunk, out, ast)
if type(out) == 'table' then
table.insert(chunk, out)
else
table.insert(chunk, {leaf = out, ast = ast})
end
end
-- Do some peephole optimization.
local function peephole(chunk)
if chunk.leaf then return chunk end
-- Optimize do ... end in some cases.
if #chunk == 3 and
chunk[1].leaf == 'do' and
not chunk[2].leaf and
chunk[3].leaf == 'end' then
return peephole(chunk[2])
end
-- Recurse
for i, v in ipairs(chunk) do
chunk[i] = peephole(v)
end
return chunk
end
-- Flatten a tree of indented Lua source code lines.
-- Tab is what is used to indent a block.
local function flattenChunk(sm, chunk, tab, depth)
if type(tab) == 'boolean' then tab = tab and ' ' or '' end
if chunk.leaf then
local code = chunk.leaf
local info = chunk.ast
-- Just do line info for now to save memory
if sm then sm[#sm + 1] = info and info.line or -1 end
return code
else
local parts = {}
for i = 1, #chunk do
-- Ignore empty chunks
if chunk[i].leaf or #(chunk[i]) > 0 then
local sub = flattenChunk(sm, chunk[i], tab, depth + 1)
if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
table.insert(parts, sub)
end
end
return table.concat(parts, '\n')
end
end
-- Some global state for all fennel sourcemaps. For the time being,
-- this seems the easiest way to store the source maps.
-- Sourcemaps are stored with source being mapped as the key, prepended
-- with '@' if it is a filename (like debug.getinfo returns for source).
-- The value is an array of mappings for each line.
local fennelSourcemap = {}
-- TODO: loading, unloading, and saving sourcemaps?
local function makeShortSrc(source)
source = source:gsub('\n', ' ')
if #source <= 49 then
return '[fennel "' .. source .. '"]'
else
return '[fennel "' .. source:sub(1, 46) .. '..."]'
end
end
-- Return Lua source and source map table
local function flatten(chunk, options)
local sm = options.sourcemap and {}
chunk = peephole(chunk)
local ret = flattenChunk(sm, chunk, options.indent, 0)
if sm then
local key, short_src
if options.filename then
short_src = options.filename
key = '@' .. short_src
else
key = ret
short_src = makeShortSrc(options.source or ret)
end
sm.short_src = short_src
sm.key = key
fennelSourcemap[key] = sm
end
return ret, sm
end
-- Convert expressions to Lua string
local function exprs1(exprs)
local t = {}
for _, e in ipairs(exprs) do
t[#t + 1] = e[1]
end
return table.concat(t, ', ')
end
-- Compile side effects for a chunk
local function keepSideEffects(exprs, chunk, start, ast)
start = start or 1
for j = start, #exprs do
local se = exprs[j]
-- Avoid the rogue 'nil' expression (nil is usually a literal,
-- but becomes an expression if a special form
-- returns 'nil'.)
if se.type == 'expression' and se[1] ~= 'nil' then
emit(chunk, ('do local _ = %s end'):format(tostring(se)), ast)
elseif se.type == 'statement' then
emit(chunk, tostring(se), ast)
end
end
end
-- Does some common handling of returns and register
-- targets for special forms. Also ensures a list expression
-- has an acceptable number of expressions if opts contains the
-- "nval" option.
local function handleCompileOpts(exprs, parent, opts, ast)
if opts.nval then
local n = opts.nval
if n ~= #exprs then
local len = #exprs
if len > n then
-- Drop extra
keepSideEffects(exprs, parent, n + 1, ast)
for i = n, len do
exprs[i] = nil
end
else
-- Pad with nils
for i = #exprs + 1, n do
exprs[i] = expr('nil', 'literal')
end
end
end
end
if opts.tail then
emit(parent, ('return %s'):format(exprs1(exprs)), ast)
end
if opts.target then
emit(parent, ('%s = %s'):format(opts.target, exprs1(exprs)), ast)
end
if opts.tail or opts.target then
-- Prevent statements and expression from being used twice if they
-- have side-effects. Since if the target or tail options are set,
-- the expressions are already emitted, we should not return them. This
-- is fine, as when these options are set, the caller doesn't need the result
-- anyways.
exprs = {}
end
return exprs
end
-- Compile an AST expression in the scope into parent, a tree
-- of lines that is eventually compiled into Lua code. Also
-- returns some information about the evaluation of the compiled expression,
-- which can be used by the calling function. Macros
-- are resolved here, as well as special forms in that order.
-- the 'ast' param is the root AST to compile
-- the 'scope' param is the scope in which we are compiling
-- the 'parent' param is the table of lines that we are compiling into.
-- add lines to parent by appending strings. Add indented blocks by appending
-- tables of more lines.
-- the 'opts' param contains info about where the form is being compiled.
-- Options include:
-- 'target' - mangled name of symbol(s) being compiled to.
-- Could be one variable, 'a', or a list, like 'a, b, _0_'.
-- 'tail' - boolean indicating tail position if set. If set, form will generate a return
-- instruction.
local function compile1(ast, scope, parent, opts)
opts = opts or {}
local exprs = {}
-- Compile the form
if isList(ast) then
-- Function call or special form
local len = #ast
assert(len > 0, "expected a function to call")
-- Test for special form
local first = ast[1]
if isSym(first) then -- Resolve symbol
first = first[1]
end
local special = scope.specials[first]
if special and isSym(ast[1]) then
-- Special form
exprs = special(ast, scope, parent, opts) or expr('nil', 'literal')
-- Be very accepting of strings or expression
-- as well as lists or expressions
if type(exprs) == 'string' then exprs = expr(exprs, 'expression') end
if getmetatable(exprs) == EXPR_MT then exprs = {exprs} end
-- Unless the special form explicitly handles the target, tail, and nval properties,
-- (indicated via the 'returned' flag, handle these options.
if not exprs.returned then
exprs = handleCompileOpts(exprs, parent, opts, ast)
elseif opts.tail or opts.target then
exprs = {}
end
exprs.returned = true
return exprs
else
-- Function call
local fargs = {}
local fcallee = compile1(ast[1], scope, parent, {
nval = 1
})[1]
assert(fcallee.type ~= 'literal', 'cannot call literal value')
fcallee = tostring(fcallee)
for i = 2, len do
local subexprs = compile1(ast[i], scope, parent, {
nval = i ~= len and 1 or nil
})
fargs[#fargs + 1] = subexprs[1] or expr('nil', 'literal')
if i == len then
-- Add sub expressions to function args
for j = 2, #subexprs do
fargs[#fargs + 1] = subexprs[j]
end
else
-- Emit sub expression only for side effects
keepSideEffects(subexprs, parent, 2, ast[i])
end
end
local call = ('%s(%s)'):format(tostring(fcallee), exprs1(fargs))
exprs = handleCompileOpts({expr(call, 'statement')}, parent, opts, ast)
end
elseif isVarg(ast) then
assert(scope.vararg, "unexpected vararg")
exprs = handleCompileOpts({expr('...', 'varg')}, parent, opts, ast)
elseif isSym(ast) then
local e
-- Handle nil as special symbol - it resolves to the nil literal rather than
-- being unmangled. Alternatively, we could remove it from the lua keywords table.
if ast[1] == 'nil' then
e = expr('nil', 'literal')
else
e = symbolToExpression(ast, scope)
end
exprs = handleCompileOpts({e}, parent, opts, ast)
elseif type(ast) == 'nil' or type(ast) == 'boolean' then
exprs = handleCompileOpts({expr(tostring(ast), 'literal')}, parent, opts)
elseif type(ast) == 'number' then
local n = ('%.17g'):format(ast)
exprs = handleCompileOpts({expr(n, 'literal')}, parent, opts)
elseif type(ast) == 'string' then
local s = serializeString(ast)
exprs = handleCompileOpts({expr(s, 'literal')}, parent, opts)
elseif type(ast) == 'table' then
local buffer = {}
for i = 1, #ast do -- Write numeric keyed values.
buffer[#buffer + 1] = tostring(compile1(ast[i], scope, parent, {nval = 1})[1])
end
local keys = {}
for k, _ in pairs(ast) do -- Write other keys.
if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
local kstr
if type(k) == 'string' and isValidLuaIdentifier(k) then
kstr = k
else
kstr = '[' .. tostring(compile1(k, scope, parent, {nval = 1})[1]) .. ']'
end
table.insert(keys, { kstr, k })
end
end
table.sort(keys, function (a, b) return a[1] < b[1] end)
for _, k in ipairs(keys) do
local v = ast[k[2]]
buffer[#buffer + 1] = ('%s = %s'):format(
k[1], tostring(compile1(v, scope, parent, {nval = 1})[1]))
end
local tbl = '({' .. table.concat(buffer, ', ') ..'})'
exprs = handleCompileOpts({expr(tbl, 'expression')}, parent, opts, ast)
else
error('could not compile value of type ' .. type(ast))
end
exprs.returned = true
return exprs
end
-- SPECIALS --
-- For statements and expressions, put the value in a local to avoid
-- double-evaluating it.
local function once(val, ast, scope, parent)
if val.type == 'statement' or val.type == 'expression' then
local s = gensym(scope)
emit(parent, ('local %s = %s'):format(s, tostring(val)), ast)
return expr(s, 'sym')
else
return val
end
end
-- Implements destructuring for forms like let, bindings, etc.
-- Takes a number of options to control behavior.
-- var: Whether or not to mark symbols as mutable
-- declaration: begin each assignment with 'local' in output
-- nomulti: disallow multisyms in the destructuring. Used for (local) and (global).
-- noundef: Don't set undefined bindings. (set)
-- forceglobal: Don't allow local bindings
local function destructure(to, from, ast, scope, parent, opts)
opts = opts or {}
local isvar = opts.isvar
local declaration = opts.declaration
local nomulti = opts.nomulti
local noundef = opts.noundef
local forceglobal = opts.forceglobal
local setter = declaration and "local %s = %s" or "%s = %s"
-- Get Lua source for symbol, and check for errors
local function getname(symbol, up1)
local raw = symbol[1]
assertCompile(not (nomulti and isMultiSym(raw)),
'did not expect multisym', up1)
if declaration then
return declareLocal(symbol, {var = isvar}, scope, symbol)
else
local parts = isMultiSym(raw) or {raw}
local meta = scope.symmeta[parts[1]]
if #parts == 1 then
assertCompile(not(forceglobal and meta),
'expected global, found var', up1)
assertCompile(meta or not noundef,
'expected local var ' .. parts[1], up1)
assertCompile(not (meta and not meta.var),
'expected local var', up1)
end
return symbolToExpression(symbol, scope)[1]
end
end
-- Recursive auxiliary function
local function destructure1(left, rightexprs, up1)
if isSym(left) and left[1] ~= "nil" then
emit(parent, setter:format(getname(left, up1), exprs1(rightexprs)), left)
elseif isTable(left) then -- table destructuring
local s = gensym(scope)
emit(parent, ("local %s = %s"):format(s, exprs1(rightexprs)), left)
for i, v in ipairs(left) do
if isSym(left[i]) and left[i][1] == "&" then
assertCompile(not left[i+2],
"expected rest argument in final position", left)
local subexpr = expr(('{(table.unpack or unpack)(%s, %s)}'):format(s, i),
'expression')
destructure1(left[i+1], {subexpr}, left)
return
else
local subexpr = expr(('%s[%d]'):format(s, i), 'expression')
destructure1(v, {subexpr}, left)
end
end
elseif isList(left) then -- values destructuring
local leftNames, tables = {}, {}
for i, name in ipairs(left) do
local symname
if isSym(name) then -- binding directly to a name
symname = getname(name, up1)
else -- further destructuring of tables inside values
symname = gensym(scope)
tables[i] = {name, expr(symname, 'sym')}
end
table.insert(leftNames, symname)
end
emit(parent, setter:
format(table.concat(leftNames, ", "), exprs1(rightexprs)), left)
for _, pair in pairs(tables) do -- recurse if left-side tables found
destructure1(pair[1], {pair[2]}, left)
end
else
assertCompile(false, 'unable to destructure ' .. tostring(left), up1)
end
end
local rexps = compile1(from, scope, parent)
local ret = destructure1(to, rexps, ast)
return ret
end
-- Unlike most expressions and specials, 'values' resolves with multiple
-- values, one for each argument, allowing multiple return values. The last
-- expression, can return multiple arguments as well, allowing for more than the number
-- of expected arguments.
local function values(ast, scope, parent)
local len = #ast
local exprs = {}
for i = 2, len do
local subexprs = compile1(ast[i], scope, parent, {})
exprs[#exprs + 1] = subexprs[1] or expr('nil', 'literal')
if i == len then
for j = 2, #subexprs do
exprs[#exprs + 1] = subexprs[j]
end
else
-- Emit sub expression only for side effects
keepSideEffects(subexprs, parent, 2, ast)
end
end
return exprs
end
-- Compile a list of forms for side effects
local function compileDo(ast, scope, parent, start)
start = start or 2
local len = #ast
local subScope = makeScope(scope)
for i = start, len do
compile1(ast[i], subScope, parent, {
nval = 0
})
end
end
-- Implements a do statement, starting at the 'start' element. By default, start is 2.
local function doImpl(ast, scope, parent, opts, start, chunk, subScope)
start = start or 2
subScope = subScope or makeScope(scope)
chunk = chunk or {}
local len = #ast
local outerTarget = opts.target
local outerTail = opts.tail
local retexprs = {returned = true}
-- See if we need special handling to get the return values
-- of the do block
if not outerTarget and opts.nval ~= 0 and not outerTail then
if opts.nval then
-- Generate a local target
local syms = {}
for i = 1, opts.nval do
local s = gensym(scope)
syms[i] = s
retexprs[i] = expr(s, 'sym')
end
outerTarget = table.concat(syms, ', ')
emit(parent, ('local %s'):format(outerTarget), ast)
emit(parent, 'do', ast)
else
-- We will use an IIFE for the do
local fname = gensym(scope)
local fargs = scope.vararg and '...' or ''
emit(parent, ('local function %s(%s)'):format(fname, fargs), ast)
retexprs = expr(fname .. '(' .. fargs .. ')', 'statement')
outerTail = true
outerTarget = nil
end
else
emit(parent, 'do', ast)
end
-- Compile the body
if start > len then
-- In the unlikely case we do a do with no arguments.
compile1(nil, subScope, chunk, {
tail = outerTail,
target = outerTarget
})
-- There will be no side effects
else
for i = start, len do
local subopts = {
nval = i ~= len and 0 or opts.nval,
tail = i == len and outerTail or nil,
target = i == len and outerTarget or nil
}
local subexprs = compile1(ast[i], subScope, chunk, subopts)
if i ~= len then
keepSideEffects(subexprs, parent, nil, ast[i])
end
end
end
emit(parent, chunk, ast)
emit(parent, 'end', ast)
return retexprs
end
SPECIALS['do'] = doImpl
SPECIALS['values'] = values
-- The fn special declares a function. Syntax is similar to other lisps;