From 842d0055bf0dbad3eb27c7dd9f0caac2d50bb484 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sat, 23 Jan 2021 16:22:13 -0500 Subject: [PATCH] Upgrade to fennel 0.8.0 --- editor/brushes.json | 2 +- editor/init.fnl | 1 - editor/tiledraw.fnl | 4 +- editor/tileedit.fnl | 6 +- game/end.screen | 1 + lib/fennel.lua | 2643 ++++++++++++++++++++++++++++--------------- lib/fennelview.lua | 225 ---- main.lua | 3 +- 8 files changed, 1766 insertions(+), 1119 deletions(-) create mode 100644 game/end.screen delete mode 100644 lib/fennelview.lua diff --git a/editor/brushes.json b/editor/brushes.json index 8a62058..b7f537b 100644 --- a/editor/brushes.json +++ b/editor/brushes.json @@ -1 +1 @@ -[{"mask":"FFFFFFFFFFFFFFFF","gfx":"D5D5D5D5D5D5D5D5","flags":[]},{"mask":"00008F8F8F000000","gfx":"00000A0A0A000000","flags":[]},{"mask":"00008F8F8F000000","gfx":"00008A8A8A000000","flags":[]},{"mask":"0000BCBCBC000000","gfx":"0000141414000000","flags":[]},{"mask":"0000BCBCBC000000","gfx":"0000949494000000","flags":[]},{"mask":"0000000C0C000000","gfx":"0000000C0C000000","flags":[]},{"mask":"00000C1E1E0C0000","flags":[],"gfx":"0000000000000000"},{"mask":"3E7F7F7F7F7F7F3E","gfx":"3E7F7F7F7F7F7F3E","flags":[]}] \ No newline at end of file +[{"mask":"FFFFFFFFFFFFFFFF","gfx":"D5D5D5D5D5D5D5D5","flags":[]},{"mask":"00008F8F8F000000","gfx":"00000A0A0A000000","flags":[]},{"mask":"0000BFBFBFBF0000","gfx":"0000AAAAAAAA0000","flags":[]},{"mask":"0000BCBCBC000000","gfx":"0000141414000000","flags":[]},{"mask":"0000BCBCBC000000","gfx":"0000949494000000","flags":[]},{"mask":"0000000C0C000000","gfx":"0000000C0C000000","flags":[]},{"mask":"00000C1E1E0C0000","flags":[],"gfx":"0000000000000000"},{"mask":"3E7F7F7F7F7F7F3E","gfx":"3E7F7F7F7F7F7F3E","flags":[]}] \ No newline at end of file diff --git a/editor/init.fnl b/editor/init.fnl index e392731..e56be3d 100644 --- a/editor/init.fnl +++ b/editor/init.fnl @@ -1,4 +1,3 @@ -(require :vendor.lite.main) (local util (require :lib.util)) (local TileView (require :editor.tileedit)) (local MapEditView (require :editor.mapedit)) diff --git a/editor/tiledraw.fnl b/editor/tiledraw.fnl index 0705d39..d888ee0 100644 --- a/editor/tiledraw.fnl +++ b/editor/tiledraw.fnl @@ -33,13 +33,13 @@ (var prevpal (or ?prevpal pal)) (for [bitx 0 6] (local x (+ bitx xoffset)) - (local bit (not= 0 (bit.band byte (bit.lshift 1 bitx)))) + (local b (not= 0 (bit.band byte (bit.lshift 1 bitx)))) (local prevart (. prevpal (+ 1 (% x 2)))) (local art (. pal (+ 1 (% x 2)))) (set prevstate state) (set prevpal pal) (set state - (match [prevstate bit] + (match [prevstate b] [:off false] :off [:off true] :rising [:rising false] :falling diff --git a/editor/tileedit.fnl b/editor/tileedit.fnl index e6820e8..82b96e8 100644 --- a/editor/tileedit.fnl +++ b/editor/tileedit.fnl @@ -56,11 +56,11 @@ (activate self :tile x y editor-w editor-h) (for [bitx 0 (- w 1)] (for [bity 0 (- h 1)] (local (ibyte ibit) (self:map-bitxy bitx bity)) - (local bit (get-bit tile ibyte ibit)) + (local b (get-bit tile ibyte ibit)) (local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1))))) (if (= ibit 7) - (draw-bit-color bit px py) - (draw-bit bit px py (= (% bitx 2) 1))) + (draw-bit-color b px py) + (draw-bit b px py (= (% bitx 2) 1))) (when (and (active? self :tile) (mouse-inside px py pixel-size pixel-size)) (when (= self.bit nil) (set self.bit (not bit))) (when (not= self.bit bit) diff --git a/game/end.screen b/game/end.screen new file mode 100644 index 0000000..fcdf783 --- /dev/null +++ b/game/end.screen @@ -0,0 +1 @@ +"0000000000000000000000000000000000000000000000000000000000000000000000000000407F7F7F7F7F7F7F7F7F7F7F3300000000000000000000000000000000007C7F87AAD5AA857F7F7F7F7F7F037E7F7FDFAAFF017F3FD0AAD57F7F7F7F7F7F7F7F7F550ED58AD57F7F1F00000000000000607F00000000000000007F000000000000000000000000000000000000000000000000000000000000000000000000707F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87FAFFFF857F7F7F7F7F077E7FFFAFD52A550A000000000000000000000000542A552A00000000007F80808080808080007F00000000000000007F7F030000000000000000000000000000000000000000000000000000000000000000407F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080AA8500000000000000007C7F87AAD5AA857F7F7F7F7F077F7FFF2BD52AFF2B81000000000000000000000000001500000000000060F5ABD5AA808080007F00000000000000007F7F7F0F000000000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000300000000600000000000007F7F8FAAD5AA857F7F7F7F7F077FFFFFAFD5AAD5AA9580000000000000000000000000000000000000C0AAD5AAD5AAC0AA80F07F00000000000000007F7F7F7F3F00000000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000028552A000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F8FFDBFD5AAD5AAD58A800000000000000000000000000000000000C0AAD5AAD5AAC1AA85FC7F00000000000000007F7F7F7F7F7F01000000000000000000000000000000000000000000000000407F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F205528540A00030040010060F09A000000007F7F0F607F7F7F7F7F7F7F7F077F9FE0FFD5AAD5AA85000000000000000000000000000000000000000000FCFFD1AAD5AAF07F7F00000000000000007F7F7F7F7F7F7F0700000000000000000000000000000000000000000000607F7F1F407F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00542A0000000300400100600000000000007C7F7F7F7F7F7F7F7F7F7F7F0F7CFFFFFFDFAA808080000000000000000000000000000000000000000000C0AAD5AAD5AAFD7F7F00000000000000007F7F7F7F7F7F7F7F7F01000000000000000000000000000000000000007F7F07D0AA857F7F7F7F7F7F7F7F07787F7F037F3F00D0AAD58200030040010078000000D4AA857C7F7F070000000000607F7F7F787FFFFFFFAAD5AA85000000000000000000000000000000000000000000000000A0D5AAF17F7F00000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87AAF5AF857F7F7F7F7F7F037F7F7FD5AAF5031F7FD7AAD5737F7F7F7F7F7F7F7F553ED58AD07F7F1F00000000000000407F00000000000000007F010000000000000000000000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87FAFFFF857F7F7F7F7F077F7FFFAFD52A550A000000000000000000000000542A512A01000000007FF0838080808080007F00000000000000007F7F070000000000000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080808000000000000000007C7F87AAD5AA857F7F7F7F7F077FFFFF2BD52AFF2B81000000000000000000000000001400000000000000D5AAD5AAC08280007F00000000000000007F7F7F1F000000000000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000300400100600000000000007F7F8FAAD5AA857F7F7F7F7F077FBFFEAFD5AAD5AAD580000000000000000000000000000000000000C0AAD5AAD5AAC0AA80F87F00000000000000007F7F7F7F7F000000000000000000000000000000000000000000000000000000007C7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000028552A000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F8FF5BFD5AAD5AAD58A800000000000000000000000000000000000C0AAD5AAD5AAD5AA817E7F00000000000000007F7F7F7F7F7F03000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F201528550A00030040010060F09A000000007F7F7F7F7F7F7F7F7F7F7F7F077FBFE0FFD5AAD5AA850000000000000000000000000000000000000000008080D0AAD5AAF07F7F00000000000000007F7F7F7F7F7F7F0F00000000000000000000000000000000000000000000787F7F01407F7F7F7F7F7F7F7F7F3F00007E7F3F00552A0000000300400100780000000000007C7F7F7F7F7F7F7F7F7F7F7F1F7CFFFFFFDFAA818080000000000000000000000000000000000000000000D0AAD5AAD5AAFF7F7F00000000000000007F7F7F7F7F7F7F7F7F03000000000000000000000000000000000000007F7F03D4AA857F7F7F7F7F7F7F3F007C7F7F037E3F80D5AAD58200030040010078000080D5AA957C7F7F010000000000007F7F7F787FFFFFFFABD5AA85000000000000000000000000000000000000000000000000A0D5AAC17F7F00000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000707F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87AAFDFF877F7F7F7F7F7F417F7FFFD5AAD507617FDFAAF5730700000000000070557ED5AAC17F7F1F00000000000000007F00000000000000007F0F00000000000000000000000000000000000000000000000000000000000000000000007C7F7F7F7F7F7F7F7F7F7F7F3F0000000000000000808000000000000000007C7F87FAFFFF857F7F7F7F7F077F7FFFAFD52A550A000000000000000000000000402A412A01000000007FF9878080808080007F00000000000000007F7F0F0000000000000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080808000000000000000007E7F87AAD5AA857F7F7F7F7F077FFFFFABD52AFD2A81000000000000000000000000000000000000000000D4AAD5AAC08A80407F00000000000000007F7F7F3F0000000000000000000000000000000000000000000000000000000000007C7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000300400100600000000000007F7F8FAAD5AA857F7F7F7F7F077FBFFCAFD5AAD5AAD582000000000000000000000000000000000000C0AAD5AAD5AAC0AA81F87F00000000000000007F7F7F7F7F000000000000000000000000000000000000000000000000000000007F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000028552A000300400100600000000000007F7F87AAD5AA807F7F7F7F7F077F8FF5BFD5AAD5AAD58A0000000000000000000000000000000000000080D5AAD5AAD5AA817E7F00000000000000007F7F7F7F7F7F07000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F200528552A00030040010060F09A000000007F7F7F7F7F7F7F7F7F7F7F7F077FFFC1FFD5AAF5AF850000000000000000000000000000000000000000008080D0AAD5AAF07F7F00000000000000007F7F7F7F7F7F7F1F000000000000000000000000000000000000000000007C7F7F80C07F7F7F7F7F7F7F7F7F0300007C7F3F00552A0000000300400100780000000000007C7F7F7F7F7F7F7F7F7F7F7F1F7CFFFFFFDFAA818080000000000000000000000000000000000000000000D0AAD5AAD5AAFF7F7F00000000000000007F7F7F7F7F7F7F7F7F07000000000000000000000000000000000000007F7F01D4AA857F7F7F7F7F7F7F03007F7F7F037E3F80D5AAD582000300400100780000A0D5AA957C7F7F000000000000007E7F7F787FFFFFFFABD5AA85000000000000000000000000000000000000000000000000A0D5AA817F7F00000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87AAFFFF877F7F7F7F7F3F407F7FFFD5AAD5866000C0AA85000000000000000000540254AA81007F1F00000000000000007F00000000000000007F1F00000000000000000000000000000000000000000000000000000000000000000000007F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080808000000000000000007C7F87FAFFFF857F7F7F7F7F077F7FFFAB552A7D280000000000000000000000000028052A01000000007EE5AF8080808080007F00000000000000007F7F3F0000000000000000000000000000000000000000000000000000000000000000707F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080800000000000000000007F7F87AAD5AA857F7F7F7F7F077FFF7FABD52AD52A850000000000000000000000000000000000000000A8D5AAD5AAC0AA80607F00000000000000007F7F7F7F0000000000000000000000000000000000000000000000000000000000007E7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F9FF8AFD5AAD5AAD582000000000000000000000000000000000000C0AAD5AAD5AAC0AA81F87F00000000000000007F7F7F7F7F010000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00552A552A00030040010060401F000000007F7F87AAD58A807F7F7F7F7F077F8FF5BFD5AAD5AAD58A0000000000000000000000000000000000000080D5AAD5AAD5AA817E7F00000000000000007F7F7F7F7F7F0F0000000000000000000000000000000000000000000000007C7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F200128552A00030040010060F09A000000007F7F7F7F7F7F7F7F7F7F7F7F077FFF87FFD5EAFFFF870000000000000000000000000000000000000000008080D0AAD5AAF07F7F00000000000000007F7F7F7F7F7F7F7F000000000000000000000000000000000000000000007E7F0F80C47F7F7F7F7F7F7F7F7F010000787F3F00552A0000400300400100780000000000007C7F7F7F7F01707F7F7F7F7F1F7CFFFFFFDFAA818080000000000000000000000000000000000000000000D0AAD5AAD5AAFF7F7F00000000000000007F7F7F7F7F7F7F7F7F0F0000000000000000007E7F7F7F7F7F7F7F7F437F3F80D5AA857F7F7F7F7F7F7F00407F7F7F077C3F80D5AAD582000300400100780000A0D5AA957C7F3F000000000000007C7F7F607FFFFFFFAFD5AA85000000000000000000000000000000000000000000000000A8D5AA817E7F000000000000000003000000000000000000000000000000000000000000000000000000000000000000000000007E7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87AAFFFF877F7F7F7F7F3F607F7FFFD5AAD586000000AA85000000000000000000500254AA85007E1F00808000000000007F00000000000000007F3F00000000000000000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080808000000000000000007C7F87FAFFAF857F7F7F7F7F077F7FFFAB552ABF280000000000000000000000000028052A01000000007CC1AF9580808080007F00000000000000007F7F7F00000000000000000000000000000000000000000000000000000000000000007C7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007F7F87AAD5AA857F7F7F7F7F077FFF7FAFD52A552A850000000000000000000000000000000000000000AAD5AAD5AAC0AA80607F00000000000000007F7F7F7F0100000000000000000000000000000000000000000000000000000000407F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000000550A000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F8FFCBFD5AAD5AAD582800000000000000000000000000000000000C0AAD5AAD5AAC0AA81F87F00000000000000007F7F7F7F7F030000000000000000000000000000000000000000000000000000707F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00552A050000030040010060401F000000007F7F87828000407F7F7F7F7F077F8FF5FFD5AAD5AAD5820000000000000000000000000000000000000080D5AAD5AAD5AA807E7F00000000000000007F7F7F7F7F7F1F0000000000000000000000000000000000000000000000007E7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00002A552A00030040010060F09A000000007F7F7F7F7F7F7F7F7F7F7F7F077FFFFFFFD7EAFFFF870000000000000000000000000000000000000000008080D0AAD5AAF97F7F00000000000000007F7F7F7F7F7F7F7F030000000000000000000000000000000000000000407F7F0380C57F7F7F7F7F7F7F7F7F010000707F3F0055280000400300400100780000000000007C7F7F7F3F0000007F7F7F7F1F7CFFFFFFDFAA858080000000000000000000000000000000000000000000D0AAD5AAD4AAFF7F7F00000000000000007F7F7F7F7F7F7F7F7F1F0000007E3F0000787F7F0F007F7F7F7F7F7F7F7F1F80D5AA857F7F7F7F7F7F3F00607F7F7F0F783F80D5AAD582000300400100780000A0D5AAD57C7F1F00000000000000787F7F607FFFFFFFAFD5AA81000000000000000000000000000000000000000000000000A8D5AA81787F000000000000000007000000000000000000000000000000000000000000000000000000000000000000000000007F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87AAFFFF877F7F7F7F7F1F707F7FBFD5AAD58E000000000000000000000000540A542A55AA85007C1F00808080000000007F00000000000000007F7F00000000000000000000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080AA8500000000000000007C7F87FAFFAF857F7F7F7F7F077F7FFF2B552ABF2800000000000000000000000000281528010000000078C1AFD582808080007F00000000000000007F7F7F01000000000000000000000000000000000000000000000000000000000000007E7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007F7F8FAAD5AA857F7F7F7F7F077F7F7FAFD52A552A8500000000000000000000000000000000000000C0AAD5AAD5AAC0AA80E07F00000000000000007F7F7F7F0300000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000000550A000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F8FFCBFD5AAD5AAD582800000000000000000000000000000000000C0AAD5AAD5AAC0AA81F87F00000000000000007F7F7F7F7F070000000000000000000000000000000000000000000000000000707F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00552A000000030040010060401F000000007F7F07000000707F7F7F7F7F077F8FF5FFD5AAD5AA95000000000000000000000000000000000000000080D5AAD5AAD5AA807E7F00000000000000007F7F7F7F7F7F1F0000000000000000000000000000000000000000000000007F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00402A552A00030040010060F09A000000007F7F7F7F7F7F7F7F7F7F7F7F077EFFFFFFD7EAFFFF870000000000000000000000000000000000000000008080D4AAD5AAFD7F7F00000000000000007F7F7F7F7F7F7F7F0F0000000000000000000000000000000000000000707F7F00A8857F7F7F7F7F7F7F7F7F407F1F607F3F0000280000000300400100780000000000007C7F7F7F0F000000007E7F7F1F78FFFFFFDFAA858080000000000000000000000000000000000000000000D0AAD58AD4AAFD7F7F00000000000000007F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F1F0000000000787F7F7F7F0FA0D5AA857F7F7F7F7F7F1F007E7F7F7F1F703F80D5AAD582000300400100780014A0D5A2D57C7F1F00000000000000707F7F607FFFFFFFAFD5AA81000000000000000000000000000000000000000000000000A8D5AA81707F00000000000000000F000000000000000000000000000000000000000000000000000000000000000000000000407F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87AAFFFF857F7F7F7F7F0F787F7FAFD5AAD59E000000000000000000000000542A552A55AA9500781F80808080808000007F00000000000000007F7F010000000000000000000000000000000000000000000000000000000000000000007E7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080AA8500000000000000007C7F87AAFFAB857F7F7F7F7F077F7FFF2B552AFF0800000000000000000000000000201528010000000070E5AFD5AA808080007F00000000000000007F7F7F03000000000000000000000000000000000000000000000000000000000000007F7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000007C7F7F7F7F3F0000000000007F7F8FAAD5AA857F7F7F7F7F077F7F7FAFD5AA552A9580000000000000000000000000000000000000C0AAD5AAD5AAC0AA80E07F00000000000000007F7F7F7F0F00000000000000000000000000000000000000000000000000000000707F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000020550A000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F8FFDBFD5AAD5AAD582800000000000000000000000000000000000C0AAD5AAD5AAC0AA81F87F00000000000000007F7F7F7F7F0F0000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F20552A000000030040010060401F000000007F7F070000007C7F7F7F7F7F077F8FF4FFD5AAD5AA85000000000000000000000000000000000000000080D5EADFAAD5AA807E7F00000000000000007F7F7F7F7F7F3F0000000000000000000000000000000000000000000000407F7F7F437F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00502A552A00030040010060701F000000007E7F7F7F7F7F7F7F7F7F7F7F077CFFFFFFD7EA8780800000000000000000000000000000000000000000008080D5AAD5AAFD7F7F00000000000000007F7F7F7F7F7F7F7F3F0000000000000000000000000000000000000000787F3F00AA857F7F7F7F7F7F7F7F3F707F3F407F3F000028000000030040010078000000D0AA007C7F7F7F0000000000787F7F1F78FFFFFFFFAAD58280000000000000000000000000000000000000000000C0AAD58AD5AAF97F7F00000000000000007F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F03000000000000007C017C7F07A8D5AA857F7F7F7F7F7F0F707F7F7F7F3F401F70D5AAD582000300400100780054A0D5A2D57C7F1F00000000000000607F7F607FFFFFFFAFD5AA81000000000000000000000000000000000000000000000000A8D5AA81607F00000000000000003F000000000000000000000000000000000000000000000000000000000000000000000000607F7F7F7F7F7F7F7F7F7F7F3F0000000000000000000000000000000000007C7F87EAFFFF857F7F7F7F7F077C7F7FAFD5AAD58E000000000000000000000000542A552A05A09500703F80808080808000007F00000000000000007F7F010000000000000000000000000000000000000000000000000000000000000000007F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000000080AA8500000000000000007C7F87AAD5AA857F7F7F7F7F077F7FFF2B552AFF0B00000000000000000000000000201500000000000070FDAFD5AA808080007F00000000000000007F7F7F07000000000000000000000000000000000000000000000000000000000000407F7F7F7F7F7F7F7F7F7F7F7F7F7F3F0000000000007F7F7F7F7F3F0000000000007F7F8FAAD5AA857F7F7F7F7F077F7F7FAFD5AAD5AA9580000000000000000000000000000000000000C0AAD5AAD5AAC0AA80E07F00000000000000007F7F7F7F1F00000000000000000000000000000000000000000000000000000000787F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F000020552A000300400100600000000000007F7F87AAD5AA857F7F7F7F7F077F8FFDBFD5AAD5AAD582800000000000000000000000000000000000C0AAD5AAD5AAC0AA81F87F00000000000000007F7F7F7F7F7F00000000000000000000000000000000000000000000000000007E7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F3F20552A000000030040010060F09A000000007F7F070000007F7F7F7F7F7F077F9FF4FFD5AAD5AA85000000000000000000000000000000000000000000FCFFDFAAD5AA807F7F00000000000000007F7F7F7F7F7F7F0100000000000000000000000000000000000000000000407F7F7F407F7F7F7F7F7F7F7F7F7F7F7F7F7F3F00502A552A00030040010060701F000000007C7F7F7F7F7F7F7F7F7F7F7F077CFFFFFFD7AA80808000000000000000000000000000000000000000000080A0D5AAD5AAFD7F7F00000000000000007F7F7F7F7F7F7F7F7F00000000000000000000000000000000000000007C7F1FC0AA857F7F7F7F7F7F7F7F1F787F7F417F3F000028000000030040010078000000D0AA817C7F7F1F0000000000707F7F3F78FFFFFFFFAAD5AA85000000000000000000000000000000000000000000C0AA9580D5AAF97F7F00000000000000007F7F7F7F7F7F7F7F7F7F337E7F7F7F7F7F7F0F0000000000000000007C7F87A8D5AA857F7F7F7F7F7F077C7F7F7F7F7F00677FD5AAD57F0703004001007E7F55A0D582D57C7F1F00000000000000607F7F607FFFFFFFAFD5AA00000000000000000000000000000000000000000000000000A8D5AA81407F0000000000000000" \ No newline at end of file diff --git a/lib/fennel.lua b/lib/fennel.lua index 1299f0e..7384b1e 100644 --- a/lib/fennel.lua +++ b/lib/fennel.lua @@ -26,7 +26,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) if (_0_0 == "Lua Compile") then return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n") elseif (_0_0 == "Runtime") then - return (compiler.traceback(err, 4) .. "\n") + return (compiler.traceback(tostring(err), 4) .. "\n") else local _ = _0_0 return ("%s error: %s\n"):format(errtype, tostring(err)) @@ -50,6 +50,111 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end return table.concat(spliced_source, "\n") end + local commands = {} + local function command_3f(input) + return input:match("^%s*,") + end + local function command_docs() + local _0_ + do + local tbl_0_ = {} + for name, f in pairs(commands) do + tbl_0_[(#tbl_0_ + 1)] = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) + end + _0_ = tbl_0_ + end + return table.concat(_0_, "\n") + end + commands.help = function(_, _0, on_values) + 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 ,exit - Leave the repl.\n\nUse (doc something) to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) + end + do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.") + local function reload(module_name, env, on_values, on_error) + local _0_0, _1_0 = pcall(specials["load-code"]("return require(...)", env), module_name) + if ((_0_0 == true) and (nil ~= _1_0)) then + local old = _1_0 + local _ = nil + package.loaded[module_name] = nil + _ = nil + local ok, new = pcall(require, module_name) + local new0 = nil + if not ok then + on_values({new}) + new0 = old + else + new0 = new + end + if ((type(old) == "table") and (type(new0) == "table")) then + for k, v in pairs(new0) do + old[k] = v + end + for k in pairs(old) do + if (nil == new0[k]) then + old[k] = nil + end + end + package.loaded[module_name] = old + end + return on_values({"ok"}) + elseif ((_0_0 == false) and (nil ~= _1_0)) then + local msg = _1_0 + local function _3_() + local _2_0 = msg:gsub("\n.*", "") + return _2_0 + end + return on_error("Runtime", _3_()) + end + end + commands.reload = function(env, read, on_values, on_error) + local _0_0, _1_0, _2_0 = pcall(read) + if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then + local module_sym = _2_0 + return reload(tostring(module_sym), env, on_values, on_error) + elseif ((_0_0 == false) and true and true) then + local _3fparse_ok = _1_0 + local _3fmsg = _2_0 + return on_error("Parse", (_3fmsg or _3fparse_ok)) + end + end + do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.") + commands.reset = function(env, _, on_values) + env.___replLocals___ = {} + return on_values({"ok"}) + end + do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.") + local function load_plugin_commands() + if (utils.root and utils.root.options and utils.root.options.plugins) then + for _, plugin in ipairs(utils.root.options.plugins) do + for name, f in pairs(plugin) do + local _0_0 = name:match("^repl%-command%-(.*)") + if (nil ~= _0_0) then + local cmd_name = _0_0 + commands[cmd_name] = (commands[cmd_name] or f) + end + end + end + return nil + end + end + local function run_command(input, read, loop, env, on_values, on_error) + load_plugin_commands() + local command_name = input:match(",([^%s/]+)") + do + local _0_0 = commands[command_name] + if (nil ~= _0_0) then + local command = _0_0 + command(env, read, on_values, on_error) + else + local _ = _0_0 + if ("exit" ~= command_name) then + on_values({"Unknown command", command_name}) + end + end + end + if ("exit" ~= command_name) then + return loop() + end + end local function completer(env, scope, text) local matches = {} local input_fragment = text:gsub(".*[%s)(]+", "") @@ -100,9 +205,9 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local old_root_options = utils.root.options local env = nil if options.env then - env = utils["wrap-env"](options.env) + env = specials["wrap-env"](options.env) else - env = setmetatable({}, {__index = (_G._ENV or _G)}) + env = setmetatable({}, {__index = (rawget(_G, "_ENV") or _G)}) end local save_locals_3f = ((options.saveLocals ~= false) and env.debug and env.debug.getlocal) local opts = {} @@ -120,7 +225,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local read, reset = nil, nil local function _1_(parser_state) local c = byte_stream(parser_state) - chars[(#chars + 1)] = c + table.insert(chars, c) return c end read, reset = parser.parser(_1_) @@ -135,18 +240,29 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end opts.registerCompleter(_3_) end + local function print_values(...) + local vals = {...} + local out = {} + env._, env.__ = vals[1], vals + for i = 1, select("#", ...) do + table.insert(out, pp(vals[i])) + end + return on_values(out) + end local function loop() for k in pairs(chars) do chars[k] = nil end local ok, parse_ok_3f, x = pcall(read) - local src_string = string.char((_G.unpack or table.unpack)(chars)) + local src_string = string.char((table.unpack or _G.unpack)(chars)) utils.root.options = opts if not ok then on_error("Parse", parse_ok_3f) clear_stream() reset() return loop() + elseif command_3f(src_string) then + return run_command(src_string, read, loop, env, on_values, on_error) else if parse_ok_3f then do @@ -156,32 +272,28 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) clear_stream() on_error("Compile", msg) elseif ((_4_0 == true) and (nil ~= _5_0)) then - local source = _5_0 - local source0 = nil + local src = _5_0 + local src0 = nil if save_locals_3f then - source0 = splice_save_locals(env, source) + src0 = splice_save_locals(env, src) else - source0 = source + src0 = src end - local lua_ok_3f, loader = pcall(specials["load-code"], source0, env) - if not lua_ok_3f then + local _7_0, _8_0 = pcall(specials["load-code"], src0, env) + if ((_7_0 == false) and (nil ~= _8_0)) then + local msg = _8_0 clear_stream() - on_error("Lua Compile", loader, source0) - else - local _7_0, _8_0 = nil, nil + on_error("Lua Compile", msg, src0) + elseif (true and (nil ~= _8_0)) then + local _0 = _7_0 + local chunk = _8_0 local function _9_() - return {loader()} + return print_values(chunk()) end local function _10_(...) return on_error("Runtime", ...) end - _7_0, _8_0 = xpcall(_9_, _10_) - if ((_7_0 == true) and (nil ~= _8_0)) then - local ret = _8_0 - env._ = ret[1] - env.__ = ret - on_values(utils.map(ret, pp)) - end + xpcall(_9_, _10_) end end end @@ -194,11 +306,393 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end return repl end +package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) + local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6} + local function sort_keys(_0_0, _1_0) + local _1_ = _0_0 + local a = _1_[1] + local _2_ = _1_0 + local b = _2_[1] + local ta = type(a) + local tb = type(b) + if ((ta == tb) and ((ta == "string") or (ta == "number"))) then + return (a < b) + else + local dta = type_order[ta] + local dtb = type_order[tb] + if (dta and dtb) then + return (dta < dtb) + elseif dta then + return true + elseif dtb then + return false + else + return (ta < tb) + end + end + end + local function table_kv_pairs(t) + local assoc_3f = false + local kv = {} + local insert = table.insert + for k, v in pairs(t) do + if (type(k) ~= "number") then + assoc_3f = true + end + insert(kv, {k, v}) + end + table.sort(kv, sort_keys) + if (#kv == 0) then + return kv, "empty" + else + local function _2_() + if assoc_3f then + return "table" + else + return "seq" + end + end + return kv, _2_() + end + end + local function count_table_appearances(t, appearances) + if (type(t) == "table") then + if not appearances[t] then + appearances[t] = 1 + for k, v in pairs(t) do + count_table_appearances(k, appearances) + count_table_appearances(v, appearances) + end + else + appearances[t] = ((appearances[t] or 0) + 1) + end + end + return appearances + end + local function save_table(t, seen) + local seen0 = (seen or {len = 0}) + local id = (seen0.len + 1) + if not seen0[t] then + seen0[t] = id + seen0.len = id + end + return seen0 + end + local function detect_cycle(t, seen) + local seen0 = (seen or {}) + seen0[t] = true + for k, v in pairs(t) do + if ((type(k) == "table") and (seen0[k] or detect_cycle(k, seen0))) then + return true + end + if ((type(v) == "table") and (seen0[v] or detect_cycle(v, seen0))) then + return true + end + end + return nil + end + local function visible_cycle_3f(t, options) + return (options["detect-cycles?"] and detect_cycle(t) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) + end + local function table_indent(t, indent, id) + local opener_length = nil + if id then + opener_length = (#tostring(id) + 2) + else + opener_length = 1 + end + return (indent + opener_length) + end + local pp = {} + local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix) + local indent_str = ("\n" .. string.rep(" ", indent)) + local open = nil + local function _2_() + if ("seq" == table_type) then + return "[" + else + return "{" + end + end + open = ((prefix or "") .. _2_()) + local close = nil + if ("seq" == table_type) then + close = "]" + else + close = "}" + end + local oneline = (open .. table.concat(elements, " ") .. close) + local _4_ + if (table_type == "seq") then + _4_ = options["sequential-length"] + else + _4_ = options["associative-length"] + end + if (not options["one-line?"] and (multiline_3f or (#elements > _4_) or ((indent + #oneline) > options["line-length"]))) then + return (open .. table.concat(elements, indent_str) .. close) + else + return oneline + end + end + local function pp_associative(t, kv, options, indent, key_3f) + local multiline_3f = false + local id = options.seen[t] + if (options.level >= options.depth) then + return "{...}" + elseif (id and options["detect-cycles?"]) then + return ("@" .. id .. "{...}") + else + local visible_cycle_3f0 = visible_cycle_3f(t, options) + local id0 = (visible_cycle_3f0 and options.seen[t]) + local indent0 = table_indent(t, indent, id0) + local slength = nil + local function _3_() + local _2_0 = rawget(_G, "utf8") + if _2_0 then + return _2_0.len + else + return _2_0 + end + end + local function _4_(_241) + return #_241 + end + slength = ((options["utf8?"] and _3_()) or _4_) + local prefix = nil + if visible_cycle_3f0 then + prefix = ("@" .. id0) + else + prefix = "" + end + local elements = nil + do + local tbl_0_ = {} + for _, _6_0 in pairs(kv) do + local _7_ = _6_0 + local k = _7_[1] + local v = _7_[2] + local _8_ + do + local k0 = pp.pp(k, options, (indent0 + 1), true) + local v0 = pp.pp(v, options, (indent0 + slength(k0) + 1)) + multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) + _8_ = (k0 .. " " .. v0) + end + tbl_0_[(#tbl_0_ + 1)] = _8_ + end + elements = tbl_0_ + end + return concat_table_lines(elements, options, multiline_3f, indent0, "table", prefix) + end + end + local function pp_sequence(t, kv, options, indent) + local multiline_3f = false + local id = options.seen[t] + if (options.level >= options.depth) then + return "[...]" + elseif (id and options["detect-cycles?"]) then + return ("@" .. id .. "[...]") + else + local visible_cycle_3f0 = visible_cycle_3f(t, options) + local id0 = (visible_cycle_3f0 and options.seen[t]) + local indent0 = table_indent(t, indent, id0) + local prefix = nil + if visible_cycle_3f0 then + prefix = ("@" .. id0) + else + prefix = "" + end + local elements = nil + do + local tbl_0_ = {} + for _, _3_0 in pairs(kv) do + local _4_ = _3_0 + local _0 = _4_[1] + local v = _4_[2] + local _5_ + do + local v0 = pp.pp(v, options, indent0) + multiline_3f = (multiline_3f or v0:find("\n")) + _5_ = v0 + end + tbl_0_[(#tbl_0_ + 1)] = _5_ + end + elements = tbl_0_ + end + return concat_table_lines(elements, options, multiline_3f, indent0, "seq", prefix) + end + end + local function concat_lines(lines, options, indent, force_multi_line_3f) + if (#lines == 0) then + if options["empty-as-sequence?"] then + return "[]" + else + return "{}" + end + else + local oneline = nil + local _2_ + do + local tbl_0_ = {} + for _, line in ipairs(lines) do + tbl_0_[(#tbl_0_ + 1)] = line:gsub("^%s+", "") + end + _2_ = tbl_0_ + end + oneline = table.concat(_2_, " ") + if (not options["one-line?"] and (force_multi_line_3f or oneline:find("\n") or ((indent + #oneline) > options["line-length"]))) then + return table.concat(lines, ("\n" .. string.rep(" ", indent))) + else + return oneline + end + end + end + local function pp_metamethod(t, metamethod, options, indent) + if (options.level >= options.depth) then + if options["empty-as-sequence?"] then + return "[...]" + else + return "{...}" + end + else + local _ = nil + local function _2_(_241) + return visible_cycle_3f(_241, options) + end + options["visible-cycle?"] = _2_ + _ = nil + local lines, force_multi_line_3f = metamethod(t, pp.pp, options, indent) + options["visible-cycle?"] = nil + local _3_0 = type(lines) + if (_3_0 == "string") then + return lines + elseif (_3_0 == "table") then + return concat_lines(lines, options, indent, force_multi_line_3f) + else + local _0 = _3_0 + return error("Error: __fennelview metamethod must return a table of lines") + end + end + end + local function pp_table(x, options, indent) + options.level = (options.level + 1) + local x0 = nil + do + local _2_0 = nil + if options["metamethod?"] then + local _3_0 = x + if _3_0 then + local _4_0 = getmetatable(_3_0) + if _4_0 then + _2_0 = _4_0.__fennelview + else + _2_0 = _4_0 + end + else + _2_0 = _3_0 + end + else + _2_0 = nil + end + if (nil ~= _2_0) then + local metamethod = _2_0 + x0 = pp_metamethod(x, metamethod, options, indent) + else + local _ = _2_0 + local _4_0, _5_0 = table_kv_pairs(x) + if (true and (_5_0 == "empty")) then + local _0 = _4_0 + if options["empty-as-sequence?"] then + x0 = "[]" + else + x0 = "{}" + end + elseif ((nil ~= _4_0) and (_5_0 == "table")) then + local kv = _4_0 + x0 = pp_associative(x, kv, options, indent) + elseif ((nil ~= _4_0) and (_5_0 == "seq")) then + local kv = _4_0 + x0 = pp_sequence(x, kv, options, indent) + else + x0 = nil + end + end + end + options.level = (options.level - 1) + return x0 + end + local function number__3estring(n) + local _2_0, _3_0, _4_0 = math.modf(n) + if ((nil ~= _2_0) and (_3_0 == 0)) then + local int = _2_0 + return tostring(int) + else + local _5_ + do + local frac = _3_0 + _5_ = (((_2_0 == 0) and (nil ~= _3_0)) and (frac < 0)) + end + if _5_ then + local frac = _3_0 + return ("-0." .. tostring(frac):gsub("^-?0.", "")) + elseif ((nil ~= _2_0) and (nil ~= _3_0)) then + local int = _2_0 + local frac = _3_0 + return (int .. "." .. tostring(frac):gsub("^-?0.", "")) + end + end + end + local function colon_string_3f(s) + return s:find("^[-%w?\\^_!$%&*+./@:|<=>]+$") + end + local function make_options(t, options) + local defaults = {["associative-length"] = 4, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["sequential-length"] = 10, ["utf8?"] = true, depth = 128} + local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} + for k, v in pairs((options or {})) do + defaults[k] = v + end + for k, v in pairs(overrides) do + defaults[k] = v + end + return defaults + end + pp.pp = function(x, options, indent, key_3f) + local indent0 = (indent or 0) + local options0 = (options or make_options(x)) + local tv = type(x) + local function _3_() + local _2_0 = getmetatable(x) + if _2_0 then + return _2_0.__fennelview + else + return _2_0 + end + end + if ((tv == "table") or ((tv == "userdata") and _3_())) then + return pp_table(x, options0, indent0) + elseif (tv == "number") then + return number__3estring(x) + elseif ((tv == "string") and key_3f and colon_string_3f(x)) then + return (":" .. x) + elseif (tv == "string") then + return string.format("%q", x) + elseif ((tv == "boolean") or (tv == "nil")) then + return tostring(x) + else + return ("#<" .. tostring(x) .. ">") + end + end + local function view(x, options) + return pp.pp(x, make_options(x, options), 0) + end + return view +end package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...) local utils = require("fennel.utils") + local view = require("fennel.view") local parser = require("fennel.parser") local compiler = require("fennel.compiler") - local unpack = (_G.unpack or table.unpack) + local unpack = (table.unpack or _G.unpack) local SPECIALS = compiler.scopes.global.specials local function wrap_env(env) local function _0_(_, key) @@ -235,8 +729,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.kvmap((env or _G), compiler["global-unmangling"]) end local function load_code(code, environment, filename) - local environment0 = ((environment or _ENV) or _G) - if (_G.setfenv and _G.loadstring) then + local environment0 = (environment or rawget(_G, "_ENV") or _G) + if (rawget(_G, "setfenv") and rawget(_G, "loadstring")) then local f = assert(_G.loadstring(code, filename)) _G.setfenv(f, environment0) return f @@ -249,7 +743,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return (name .. " not found") else local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#")):gsub("\n$", ""):gsub("\n", "\n ") - if (type(tgt) == "function") then + local mt = getmetatable(tgt) + if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}), " ") local _0_ if (#arglist > 0) then @@ -281,46 +776,50 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local sub_scope0 = (sub_scope or compiler["make-scope"](scope)) local chunk0 = (chunk or {}) local len = #ast - local outer_target = opts.target - local outer_tail = opts.tail local retexprs = {returned = true} - if (not outer_target and (opts.nval ~= 0) and not outer_tail) then - if opts.nval then - local syms = {} - for i = 1, opts.nval, 1 do - local s = ((pre_syms and pre_syms[i]) or compiler.gensym(scope)) - syms[i] = s - retexprs[i] = utils.expr(s, "sym") - end - outer_target = table.concat(syms, ", ") - compiler.emit(parent, ("local %s"):format(outer_target), ast) - compiler.emit(parent, "do", ast) + local function compile_body(outer_target, outer_tail, outer_retexprs) + if (len < start0) then + compiler.compile1(nil, sub_scope0, chunk0, {tail = outer_tail, target = outer_target}) else - local fname = compiler.gensym(scope) - local fargs = ((scope.vararg and "...") or "") - compiler.emit(parent, ("local function %s(%s)"):format(fname, fargs), ast) - retexprs = utils.expr((fname .. "(" .. fargs .. ")"), "statement") - outer_tail = true - outer_target = nil - end - else - compiler.emit(parent, "do", ast) - end - if (len < start0) then - compiler.compile1(nil, sub_scope0, chunk0, {tail = outer_tail, target = outer_target}) - else - for i = start0, len do - local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} - utils["propagate-options"](opts, subopts) - local subexprs = compiler.compile1(ast[i], sub_scope0, chunk0, subopts) - if (i ~= len) then - compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) + for i = start0, len do + local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} + local _ = utils["propagate-options"](opts, subopts) + local subexprs = compiler.compile1(ast[i], sub_scope0, chunk0, subopts) + if (i ~= len) then + compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) + end end end + compiler.emit(parent, chunk0, ast) + compiler.emit(parent, "end", ast) + return (outer_retexprs or retexprs) + end + if (opts.target or (opts.nval == 0) or opts.tail) then + compiler.emit(parent, "do", ast) + return compile_body(opts.target, opts.tail) + elseif opts.nval then + local syms = {} + for i = 1, opts.nval do + local s = ((pre_syms and pre_syms[i]) or compiler.gensym(scope)) + syms[i] = s + retexprs[i] = utils.expr(s, "sym") + end + local outer_target = table.concat(syms, ", ") + compiler.emit(parent, string.format("local %s", outer_target), ast) + compiler.emit(parent, "do", ast) + return compile_body(outer_target, opts.tail) + else + local fname = compiler.gensym(scope) + local fargs = nil + if scope.vararg then + fargs = "..." + else + fargs = "" + end + compiler.emit(parent, string.format("local function %s(%s)", fname, fargs), ast) + utils.hook("do", ast, sub_scope0) + return compile_body(nil, true, utils.expr((fname .. "(" .. fargs .. ")"), "statement")) end - compiler.emit(parent, chunk0, ast) - compiler.emit(parent, "end", ast) - return retexprs end doc_special("do", {"..."}, "Evaluate multiple forms; return last value.") SPECIALS.values = function(ast, scope, parent) @@ -328,18 +827,76 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local exprs = {} for i = 2, len do local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)}) - exprs[(#exprs + 1)] = subexprs[1] + table.insert(exprs, subexprs[1]) if (i == len) then - for j = 2, #subexprs, 1 do - exprs[(#exprs + 1)] = subexprs[j] + for j = 2, #subexprs do + table.insert(exprs, subexprs[j]) end end end return exprs end doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.") + local function deep_tostring(x, key_3f) + local elems = {} + if utils["sequence?"](x) then + local _0_ + do + local tbl_0_ = {} + for _, v in ipairs(x) do + tbl_0_[(#tbl_0_ + 1)] = deep_tostring(v) + end + _0_ = tbl_0_ + end + return ("[" .. table.concat(_0_, " ") .. "]") + elseif utils["table?"](x) then + local _0_ + do + local tbl_0_ = {} + for k, v in pairs(x) do + tbl_0_[(#tbl_0_ + 1)] = (deep_tostring(k, true) .. " " .. deep_tostring(v)) + end + _0_ = tbl_0_ + end + return ("{" .. table.concat(_0_, " ") .. "}") + elseif (key_3f and (type(x) == "string") and x:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then + return (":" .. x) + elseif (type(x) == "string") then + return string.format("%q", x):gsub("\\\"", "\\\\\""):gsub("\"", "\\\"") + else + return tostring(x) + end + end + local function set_fn_metadata(arg_list, docstring, parent, fn_name) + if utils.root.options.useMetadata then + local args = nil + local function _0_(v) + return ("\"%s\""):format(deep_tostring(v)) + end + args = utils.map(arg_list, _0_) + local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")} + if docstring then + table.insert(meta_fields, "\"fnl/docstring\"") + table.insert(meta_fields, ("\"" .. docstring:gsub("%s+$", ""):gsub("\\", "\\\\"):gsub("\n", "\\n"):gsub("\"", "\\\"") .. "\"")) + end + local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) + return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) + end + end + local function get_fn_name(ast, scope, fn_name, multi) + if (fn_name and (fn_name[1] ~= "nil")) then + local _0_ + if not multi then + _0_ = compiler["declare-local"](fn_name, {}, scope, ast) + else + _0_ = compiler["symbol-to-expression"](fn_name, scope)[1] + end + return _0_, not multi, 3 + else + return compiler.gensym(scope), true, 2 + end + end SPECIALS.fn = function(ast, scope, parent) - local index, fn_name, is_local_fn, docstring = 2, utils["is-sym"](ast[2]) local f_scope = nil do local _0_0 = compiler["make-scope"](scope) @@ -347,80 +904,50 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct f_scope = _0_0 end local f_chunk = {} - local multi = (fn_name and utils["is-multi-sym"](fn_name[1])) - compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), ast[index]) - if (fn_name and (fn_name[1] ~= "nil")) then - is_local_fn = not multi - if is_local_fn then - fn_name = compiler["declare-local"](fn_name, {}, scope, ast) + local fn_sym = utils["sym?"](ast[2]) + local multi = (fn_sym and utils["multi-sym?"](fn_sym[1])) + local fn_name, local_fn_3f, index = get_fn_name(ast, scope, fn_sym, multi) + local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast) + compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym) + local function get_arg_name(arg) + if utils["varg?"](arg) then + compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast) + f_scope.vararg = true + return "..." + elseif (utils["sym?"](arg) and (utils.deref(arg) ~= "nil") and not utils["multi-sym?"](utils.deref(arg))) then + return compiler["declare-local"](arg, {}, f_scope, ast) + elseif utils["table?"](arg) then + local raw = utils.sym(compiler.gensym(scope)) + local declared = compiler["declare-local"](raw, {}, f_scope, ast) + compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) + return declared else - fn_name = compiler["symbol-to-expression"](fn_name, scope)[1] + return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2]) end - index = (index + 1) - else - is_local_fn = true - fn_name = compiler.gensym(scope) end do - local arg_list = nil - local function _2_() - if (type(ast[index]) == "table") then - return ast[index] - else - return ast - end - end - arg_list = compiler.assert(utils["is-table"](ast[index]), "expected parameters", _2_()) - local function get_arg_name(i, name) - if utils["is-varg"](name) then - compiler.assert((i == #arg_list), "expected vararg as last parameter", ast[2]) - f_scope.vararg = true - return "..." - elseif (utils["is-sym"](name) and (utils.deref(name) ~= "nil") and not utils["is-multi-sym"](utils.deref(name))) then - return compiler["declare-local"](name, {}, f_scope, ast) - elseif utils["is-table"](name) then - local raw = utils.sym(compiler.gensym(scope)) - local declared = compiler["declare-local"](raw, {}, f_scope, ast) - compiler.destructure(name, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true}) - return declared - else - return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(name)), ast[2]) - end - end - local arg_name_list = utils.kvmap(arg_list, get_arg_name) + local arg_name_list = utils.map(arg_list, get_arg_name) + local index0, docstring = nil, nil if ((type(ast[(index + 1)]) == "string") and ((index + 1) < #ast)) then - index = (index + 1) - docstring = ast[index] + index0, docstring = (index + 1), ast[(index + 1)] + else + index0, docstring = index, nil end - for i = (index + 1), #ast, 1 do + for i = (index0 + 1), #ast do compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)}) end - if is_local_fn then - compiler.emit(parent, ("local function %s(%s)"):format(fn_name, table.concat(arg_name_list, ", ")), ast) + local _2_ + if local_fn_3f then + _2_ = "local function %s(%s)" else - compiler.emit(parent, ("%s = function(%s)"):format(fn_name, table.concat(arg_name_list, ", ")), ast) + _2_ = "%s = function(%s)" end + compiler.emit(parent, string.format(_2_, fn_name, table.concat(arg_name_list, ", ")), ast) compiler.emit(parent, f_chunk, ast) compiler.emit(parent, "end", ast) - if utils.root.options.useMetadata then - local args = nil - local function _5_(v) - if utils["is-table"](v) then - return "\"#\"" - else - return ("\"%s\""):format(tostring(v)) - end - end - args = utils.map(arg_list, _5_) - local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")} - if docstring then - table.insert(meta_fields, "\"fnl/docstring\"") - table.insert(meta_fields, ("\"" .. docstring:gsub("%s+$", ""):gsub("\\", "\\\\"):gsub("\n", "\\n"):gsub("\"", "\\\"") .. "\"")) - end - local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) - compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) - end + set_fn_metadata(arg_list, docstring, parent, fn_name) end + utils.hook("fn", ast, f_scope) return utils.expr(fn_name, "sym") end doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring.\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.") @@ -429,7 +956,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (ast[2] ~= nil) then table.insert(parent, {ast = ast, leaf = tostring(ast[2])}) end - if (#ast == 3) then + if (ast[3] ~= nil) then return tostring(ast[3]) end end @@ -439,7 +966,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local target = utils.deref(ast[2]) local special_or_macro = (scope.specials[target] or scope.macros[target]) if special_or_macro then - return ("print([[%s]])"):format(doc_2a(special_or_macro, target)) + return ("print(%q)"):format(doc_2a(special_or_macro, target)) else local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1]) return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), value, tostring(ast[2])) @@ -449,24 +976,26 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function dot(ast, scope, parent) compiler.assert((1 < #ast), "expected table argument", ast) local len = #ast - local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local lhs = _0_[1] if (len == 2) then - return tostring(lhs[1]) + return tostring(lhs) else local indices = {} - for i = 3, len, 1 do + for i = 3, len do local index = ast[i] - if ((type(index) == "string") and utils["is-valid-lua-identifier"](index)) then + if ((type(index) == "string") and utils["valid-lua-identifier?"](index)) then table.insert(indices, ("." .. index)) else - index = compiler.compile1(index, scope, parent, {nval = 1})[1] - table.insert(indices, ("[" .. tostring(index) .. "]")) + local _1_ = compiler.compile1(index, scope, parent, {nval = 1}) + local index0 = _1_[1] + table.insert(indices, ("[" .. tostring(index0) .. "]")) end end - if utils["is-table"](ast[2]) then - return ("(" .. tostring(lhs[1]) .. ")" .. table.concat(indices)) + if (tostring(lhs):find("[{\"0-9]") or ("nil" == tostring(lhs))) then + return ("(" .. tostring(lhs) .. ")" .. table.concat(indices)) else - return (tostring(lhs[1]) .. table.concat(indices)) + return (tostring(lhs) .. table.concat(indices)) end end end @@ -474,48 +1003,48 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special(".", {"tbl", "key1", "..."}, "Look up key1 in tbl table. If more args are provided, do a nested lookup.") SPECIALS.global = function(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) - compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true}) + compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"}) return nil end doc_special("global", {"name", "val"}, "Set name as a global with val.") SPECIALS.set = function(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) - compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true}) + compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"}) return nil end doc_special("set", {"name", "val"}, "Set a local variable to a new value. Only works on locals using var.") local function set_forcibly_21_2a(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) - compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true}) + compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true, symtype = "set"}) return nil end SPECIALS["set-forcibly!"] = set_forcibly_21_2a local function local_2a(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) - compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true}) + compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"}) return nil end SPECIALS["local"] = local_2a doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.") SPECIALS.var = function(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) - compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true}) + compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"}) return nil end doc_special("var", {"name", "val"}, "Introduce new mutable local.") SPECIALS.let = function(ast, scope, parent, opts) local bindings = ast[2] local pre_syms = {} - compiler.assert((utils["is-list"](bindings) or utils["is-table"](bindings)), "expected binding table", ast) + compiler.assert((utils["list?"](bindings) or utils["table?"](bindings)), "expected binding table", ast) compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2]) compiler.assert((#ast >= 3), "expected body expression", ast[1]) - for _ = 1, (opts.nval or 0), 1 do + for _ = 1, (opts.nval or 0) do table.insert(pre_syms, compiler.gensym(scope)) end local sub_scope = compiler["make-scope"](scope) local sub_chunk = {} for i = 1, #bindings, 2 do - compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true}) + compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true, symtype = "let"}) end return SPECIALS["do"](ast, scope, parent, opts, 3, sub_chunk, sub_scope, pre_syms) end @@ -524,9 +1053,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((#ast > 3), "expected table, key, and value arguments", ast) local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local keys = {} - for i = 3, (#ast - 1), 1 do - local key = compiler.compile1(ast[i], scope, parent, {nval = 1})[1] - keys[(#keys + 1)] = tostring(key) + for i = 3, (#ast - 1) do + local _0_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) + local key = _0_[1] + table.insert(keys, tostring(key)) end local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1] local rootstr = tostring(root) @@ -539,28 +1069,26 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compiler.emit(parent, fmtstr:format(tostring(root), table.concat(keys, "]["), tostring(value)), ast) end 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.") + local function calculate_target(scope, opts) + if not (opts.tail or opts.target or opts.nval) then + return "iife", true, nil + elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then + local accum = {} + local target_exprs = {} + for i = 1, opts.nval do + local s = compiler.gensym(scope) + accum[i] = s + target_exprs[i] = utils.expr(s, "sym") + end + return "target", opts.tail, table.concat(accum, ", "), target_exprs + else + return "none", opts.tail, opts.target + end + end local function if_2a(ast, scope, parent, opts) local do_scope = compiler["make-scope"](scope) local branches = {} - local has_else = ((#ast > 3) and ((#ast % 2) == 0)) - local else_branch = nil - local wrapper, inner_tail, inner_target, target_exprs = nil - if (opts.tail or opts.target or opts.nval) then - if (opts.nval and (opts.nval ~= 0) and not opts.target) then - local accum = {} - target_exprs = {} - for i = 1, opts.nval, 1 do - local s = compiler.gensym(scope) - accum[i] = s - target_exprs[i] = utils.expr(s, "sym") - end - wrapper, inner_tail, inner_target = "target", opts.tail, table.concat(accum, ", ") - else - wrapper, inner_tail, inner_target = "none", opts.tail, opts.target - end - else - wrapper, inner_tail, inner_target = "iife", true, nil - end + local wrapper, inner_tail, inner_target, target_exprs = calculate_target(scope, opts) local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target} local function compile_body(i) local chunk = {} @@ -578,9 +1106,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil)) table.insert(branches, branch) end - if has_else then - else_branch = compile_body(#ast) - end + local has_else_3f = ((#ast > 3) and ((#ast % 2) == 0)) + local else_branch = (has_else_3f and compile_body(#ast)) local s = compiler.gensym(scope) local buffer = {} local last_buffer = buffer @@ -609,7 +1136,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.emit(last_buffer, cond_line, ast) compiler.emit(last_buffer, branch.chunk, ast) if (i == #branches) then - if has_else then + if has_else_3f then compiler.emit(last_buffer, "else", ast) compiler.emit(last_buffer, else_branch.chunk, ast) elseif (inner_target and (cond_line ~= "else")) then @@ -632,13 +1159,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.emit(parent, "end", ast) return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement") elseif (wrapper == "none") then - for i = 1, #buffer, 1 do + for i = 1, #buffer do compiler.emit(parent, buffer[i], ast) end return {returned = true} else compiler.emit(parent, ("local %s"):format(inner_target), ast) - for i = 1, #buffer, 1 do + for i = 1, #buffer do compiler.emit(parent, buffer[i], ast) end return target_exprs @@ -648,13 +1175,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("if", {"cond1", "body1", "...", "condN", "bodyN"}, "Conditional form.\nTakes any number of condition/body pairs and evaluates the first body where\nthe condition evaluates to truthy. Similar to cond in other lisps.") SPECIALS.each = function(ast, scope, parent) compiler.assert((#ast >= 3), "expected body expression", ast[1]) - local binding = compiler.assert(utils["is-table"](ast[2]), "expected binding table", ast) + local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) local iter = table.remove(binding, #binding) local destructures = {} local new_manglings = {} local sub_scope = compiler["make-scope"](scope) local function destructure_binding(v) - if utils["is-sym"](v) then + if utils["sym?"](v) then return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings) else local raw = utils.sym(compiler.gensym(sub_scope)) @@ -668,7 +1195,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local chunk = {} compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast) for raw, args in utils.stablepairs(destructures) do - compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true}) + compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"}) end compiler["apply-manglings"](sub_scope, new_manglings, ast) compile_do(ast, sub_scope, chunk, 3) @@ -682,8 +1209,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local len2 = #parent local sub_chunk = {} if (len1 ~= len2) then - for i = (len1 + 1), len2, 1 do - sub_chunk[(#sub_chunk + 1)] = parent[i] + for i = (len1 + 1), len2 do + table.insert(sub_chunk, parent[i]) parent[i] = nil end compiler.emit(parent, "while true do", ast) @@ -698,14 +1225,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS["while"] = while_2a doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.") local function for_2a(ast, scope, parent) - local ranges = compiler.assert(utils["is-table"](ast[2]), "expected binding table", ast) + local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) local binding_sym = table.remove(ast[2], 1) local sub_scope = compiler["make-scope"](scope) local range_args = {} local chunk = {} - compiler.assert(utils["is-sym"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2]) + compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2]) compiler.assert((#ast >= 3), "expected body expression", ast[1]) - for i = 1, math.min(#ranges, 3), 1 do + for i = 1, math.min(#ranges, 3) do range_args[i] = tostring(compiler.compile1(ranges[i], sub_scope, parent, {nval = 1})[1]) end compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast) @@ -715,63 +1242,81 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS["for"] = for_2a doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).") - local function once(val, ast, scope, parent) - if ((val.type == "statement") or (val.type == "expression")) then - local s = compiler.gensym(scope) - compiler.emit(parent, ("local %s = %s"):format(s, tostring(val)), ast) - return utils.expr(s, "sym") + local function native_method_call(ast, _scope, _parent, target, args) + local _0_ = ast + local _ = _0_[1] + local _0 = _0_[2] + local method_string = _0_[3] + local call_string = nil + if ((target.type == "literal") or (target.type == "expression")) then + call_string = "(%s):%s(%s)" else - return val + call_string = "%s:%s(%s)" end + return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement") + end + local function nonnative_method_call(ast, scope, parent, target, args) + local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) + local args0 = {tostring(target), unpack(args)} + return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement") + end + local function double_eval_protected_method_call(ast, scope, parent, target, args) + local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) + local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)" + table.insert(args, 1, method_string) + return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement") end local function method_call(ast, scope, parent) - compiler.assert((#ast >= 3), "expected at least 2 arguments", ast) - local objectexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] - local methodident, methodstring = false - if ((type(ast[3]) == "string") and utils["is-valid-lua-identifier"](ast[3])) then - methodident = true - methodstring = ast[3] - else - methodstring = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) - objectexpr = once(objectexpr, ast[2], scope, parent) - end + compiler.assert((2 < #ast), "expected at least 2 arguments", ast) + local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local target = _0_[1] local args = {} - for i = 4, #ast, 1 do + for i = 4, #ast do local subexprs = nil local _1_ if (i ~= #ast) then _1_ = 1 else - _1_ = nil + _1_ = nil end subexprs = compiler.compile1(ast[i], scope, parent, {nval = _1_}) utils.map(subexprs, tostring, args) end - local fstring = nil - if not methodident then - table.insert(args, 1, tostring(objectexpr)) - if (objectexpr.type == "sym") then - fstring = "%s[%s](%s)" - else - fstring = "(%s)[%s](%s)" - end - elseif ((objectexpr.type == "literal") or (objectexpr.type == "expression")) then - fstring = "(%s):%s(%s)" + if ((type(ast[3]) == "string") and utils["valid-lua-identifier?"](ast[3])) then + return native_method_call(ast, scope, parent, target, args) + elseif (target.type == "sym") then + return nonnative_method_call(ast, scope, parent, target, args) else - fstring = "%s:%s(%s)" + return double_eval_protected_method_call(ast, scope, parent, target, args) end - return utils.expr(fstring:format(tostring(objectexpr), methodstring, table.concat(args, ", ")), "statement") end SPECIALS[":"] = method_call 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.") SPECIALS.comment = function(ast, _, parent) local els = {} - for i = 2, #ast, 1 do - els[(#els + 1)] = tostring(ast[i]):gsub("\n", " ") + for i = 2, #ast do + local function _1_() + local _0_0 = tostring(ast[i]):gsub("\n", " ") + return _0_0 + end + table.insert(els, _1_()) end return compiler.emit(parent, ("-- " .. table.concat(els, " ")), ast) end doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.") + local function hashfn_max_used(f_scope, i, max) + local max0 = nil + if f_scope.symmeta[("$" .. i)].used then + max0 = i + else + max0 = max + end + if (i < 9) then + return hashfn_max_used(f_scope, (i + 1), max0) + else + return max0 + end + end SPECIALS.hashfn = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) local f_scope = nil @@ -784,35 +1329,33 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local f_chunk = {} local name = compiler.gensym(scope) local symbol = utils.sym(name) - compiler["declare-local"](symbol, {}, scope, ast) local args = {} + compiler["declare-local"](symbol, {}, scope, ast) for i = 1, 9 do args[i] = compiler["declare-local"](utils.sym(("$" .. i)), {}, f_scope, ast) end local function walker(idx, node, parent_node) - if (utils["is-sym"](node) and (utils.deref(node) == "$...")) then + if (utils["sym?"](node) and (utils.deref(node) == "$...")) then parent_node[idx] = utils.varg() f_scope.vararg = true return nil else - return (utils["is-list"](node) or utils["is-table"](node)) + return (utils["list?"](node) or utils["table?"](node)) end end utils["walk-tree"](ast[2], walker) compiler.compile1(ast[2], f_scope, f_chunk, {tail = true}) - local max_used = 0 - for i = 1, 9, 1 do - if f_scope.symmeta[("$" .. i)].used then - max_used = i - end - end + local max_used = hashfn_max_used(f_scope, 1, 0) if f_scope.vararg then compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast) - args = {utils.deref(utils.varg())} - max_used = 1 end - local arg_str = table.concat(args, ", ", 1, max_used) - compiler.emit(parent, ("local function %s(%s)"):format(name, arg_str), ast) + local arg_str = nil + if f_scope.vararg then + arg_str = utils.deref(utils.varg()) + else + arg_str = table.concat(args, ", ", 1, max_used) + end + compiler.emit(parent, string.format("local function %s(%s)", name, arg_str), ast) compiler.emit(parent, f_chunk, ast) compiler.emit(parent, "end", ast) return utils.expr(name, "sym") @@ -828,10 +1371,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(zero_arity, "literal") else local operands = {} - for i = 2, len, 1 do + for i = 2, len do local subexprs = nil local _1_ - if (i == 1) then + if (i ~= len) then _1_ = 1 else _1_ = nil @@ -877,27 +1420,41 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") doc_special("or", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.") - local function define_comparator_special(name, realop, chain_op) + local function native_comparator(op, _0_0, scope, parent) + local _1_ = _0_0 + local _ = _1_[1] + local lhs_ast = _1_[2] + local rhs_ast = _1_[3] + local _2_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) + local lhs = _2_[1] + local _3_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) + local rhs = _3_[1] + return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs)) + end + local function double_eval_protected_comparator(op, chain_op, ast, scope, parent) + local arglist = {} + local comparisons = {} + local vals = {} + local chain = string.format(" %s ", (chain_op or "and")) + for i = 2, #ast do + table.insert(arglist, tostring(compiler.gensym(scope))) + table.insert(vals, tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1])) + end + for i = 1, (#arglist - 1) do + table.insert(comparisons, string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)])) + end + return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ",")) + end + local function define_comparator_special(name, lua_op, chain_op) do - local op = (realop or name) + local op = (lua_op or name) local function opfn(ast, scope, parent) - local len = #ast - compiler.assert((len > 2), "expected at least two arguments", ast) - local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] - local lastval = compiler.compile1(ast[3], scope, parent, {nval = 1})[1] - if (len > 3) then - lastval = once(lastval, ast[3], scope, parent) + compiler.assert((2 < #ast), "expected at least two arguments", ast) + if (3 == #ast) then + return native_comparator(op, ast, scope, parent) + else + return double_eval_protected_comparator(op, chain_op, ast, scope, parent) end - local out = ("(%s %s %s)"):format(tostring(lhs), op, tostring(lastval)) - if (len > 3) then - for i = 4, len do - local nextval = once(compiler.compile1(ast[i], scope, parent, {nval = 1})[1], ast[i], scope, parent) - out = ((out .. " %s (%s %s %s)")):format((chain_op or "and"), tostring(lastval), op, tostring(nextval)) - lastval = nextval - end - out = ("(" .. out .. ")") - end - return out end SPECIALS[name] = opfn end @@ -938,22 +1495,47 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compiler["do-quote"](ast[2], scope, parent, runtime) end doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.") + local already_warned_3f = {} + local compile_env_warning = ("WARNING: Attempting to %s %s in compile" .. " scope.\nIn future versions of Fennel this will not" .. " be allowed without the\n--no-compiler-sandbox flag" .. " or passing a :compilerEnv globals table in options.\n") + local function compiler_env_warn(_, key) + local v = _G[key] + if (v and io and io.stderr and not already_warned_3f[key]) then + already_warned_3f[key] = true + do end (io.stderr):write(compile_env_warning:format("use global", key)) + end + return v + end + local safe_compiler_env = setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = getmetatable, ipairs = ipairs, math = math, next = next, pairs = pairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, select = select, setmetatable = setmetatable, string = string, table = table, tonumber = tonumber, tostring = tostring, type = type, xpcall = xpcall}, {__index = compiler_env_warn}) local function make_compiler_env(ast, scope, parent) - local function _0_() + local function _1_() return compiler.scopes.macro end - local function _1_(symbol) + local function _2_(symbol) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.scopes.macro.manglings[tostring(symbol)] end - local function _2_() - return utils.sym(compiler.gensym((compiler.scopes.macro or scope))) + local function _3_(base) + return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) end - local function _3_(form) + local function _4_(form) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.macroexpand(form, compiler.scopes.macro) end - return setmetatable({["get-scope"] = _0_, ["in-scope?"] = _1_, ["list?"] = utils["is-list"], ["multi-sym?"] = utils["is-multi-sym"], ["sequence?"] = utils["is-sequence"], ["sym?"] = utils["is-sym"], ["table?"] = utils["is-table"], ["varg?"] = utils["is-varg"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), fennel = utils["fennel-module"], gensym = _2_, list = utils.list, macroexpand = _3_, sequence = utils.sequence, sym = utils.sym, unpack = unpack}, {__index = (_ENV or _G)}) + local _6_ + do + local _5_0 = utils.root.options + if ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then + local compilerEnv = _5_0.compilerEnv + _6_ = compilerEnv + elseif ((type(_5_0) == "table") and (nil ~= _5_0["compiler-env"])) then + local compiler_env = _5_0["compiler-env"] + _6_ = compiler_env + else + local _ = _5_0 + _6_ = safe_compiler_env + end + end + return setmetatable({["assert-compile"] = compiler.assert, ["get-scope"] = _1_, ["in-scope?"] = _2_, ["list?"] = utils["list?"], ["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(), gensym = _3_, list = utils.list, macroexpand = _4_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, view = view}, {__index = _6_}) end local cfg = string.gmatch(package.config, "([^\n]+)") local dirsep, pathsep, pathmark = (cfg() or "/"), (cfg() or ";"), (cfg() or "?") @@ -969,37 +1551,39 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function try_path(path) local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module) local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename) - local _0_0 = (io.open(filename) or io.open(filename2)) - if (nil ~= _0_0) then - local file = _0_0 + local _1_0 = (io.open(filename) or io.open(filename2)) + if (nil ~= _1_0) then + local file = _1_0 file:close() return filename end end local function find_in_path(start) - local _0_0 = fullpath:match(pattern, start) - if (nil ~= _0_0) then - local path = _0_0 + local _1_0 = fullpath:match(pattern, start) + if (nil ~= _1_0) then + local path = _1_0 return (try_path(path) or find_in_path((start + #path + 1))) end end return find_in_path(1) end local function make_searcher(options) - local opts = utils.copy(utils.root.options) - for k, v in pairs((options or {})) do - opts[k] = v - end - local function _0_(module_name) - local filename = search_module(module_name) - if filename then - local function _1_(mod_name) - return utils["fennel-module"].dofile(filename, opts, mod_name) + local function _1_(module_name) + local opts = utils.copy(utils.root.options) + for k, v in pairs((options or {})) do + opts[k] = v + end + opts["module-name"] = module_name + local _2_0 = search_module(module_name) + if (nil ~= _2_0) then + local filename = _2_0 + local function _3_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - return _1_ + return _3_, filename end end - return _0_ + return _1_ end local function macro_globals(env, globals) local allowed = current_global_names(env) @@ -1008,31 +1592,47 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return allowed end + local function compiler_env_domodule(modname, env, _3fast) + local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast) + local globals = macro_globals(env, current_global_names()) + return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename) + end + local macro_loaded = {} + local function metadata_only_fennel(modname) + if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then + return {metadata = compiler.metadata} + end + end + safe_compiler_env.require = function(modname) + local function _1_() + local mod = compiler_env_domodule(modname, safe_compiler_env) + macro_loaded[modname] = mod + return mod + end + return (macro_loaded[modname] or metadata_only_fennel(modname) or _1_()) + end local function add_macros(macros_2a, ast, scope) - compiler.assert(utils["is-table"](macros_2a), "expected macros to be table", ast) + compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast) for k, v in pairs(macros_2a) do compiler.assert((type(v) == "function"), "expected each macro to be function", ast) scope.macros[k] = v end return nil end - local function load_macros(modname, ast, scope, parent) - local filename = compiler.assert(search_module(modname), (modname .. " module not found."), ast) - local env = make_compiler_env(ast, scope, parent) - local globals = macro_globals(env, current_global_names()) - return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}) - end - local macro_loaded = {} - SPECIALS["require-macros"] = function(ast, scope, parent) - compiler.assert((#ast == 2), "Expected one module name argument", ast) - local modname = ast[2] + SPECIALS["require-macros"] = function(ast, scope, parent, real_ast) + compiler.assert((#ast == 2), "Expected one module name argument", (real_ast or ast)) + local filename = (ast[2].filename or ast.filename) + local modname_code = compiler.compile(ast[2]) + local modname = load_code(modname_code, nil, filename)(utils.root.options["module-name"], filename) + compiler.assert((type(modname) == "string"), "module name must compile to string", (real_ast or ast)) if not macro_loaded[modname] then - macro_loaded[modname] = load_macros(modname, ast, scope, parent) + local env = make_compiler_env(ast, scope, parent) + macro_loaded[modname] = compiler_env_domodule(modname, env, ast) end return add_macros(macro_loaded[modname], ast, scope, parent) end 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.") - local function emit_fennel(src, path, opts, sub_chunk) + local function emit_included_fennel(src, path, opts, sub_chunk) local subscope = compiler["make-scope"](utils.root.scope.parent) local forms = {} if utils.root.options.requireAsInclude then @@ -1044,7 +1644,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct for i = 1, #forms do local subopts = nil if (i == #forms) then - subopts = {nval = 1, tail = true} + subopts = {tail = true} else subopts = {nval = 0} end @@ -1066,10 +1666,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return error(..., 0) end end - local function _0_() + local function _1_() return f:read("*all"):gsub("[\13\n]*$", "") end - src = close_handlers_0_(xpcall(_0_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_0_(xpcall(_1_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -1082,7 +1682,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct table.insert(utils.root.chunk, i, v) end if fennel_3f then - emit_fennel(src, path, opts, sub_chunk) + emit_included_fennel(src, path, opts, sub_chunk) else compiler.emit(sub_chunk, src, ast) end @@ -1106,13 +1706,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end else local mod = load_code(("return " .. modexpr[1]))() - local function _1_() - local _0_0 = search_module(mod) - if (nil ~= _0_0) then - local fennel_path = _0_0 + local function _2_() + local _1_0 = search_module(mod) + if (nil ~= _1_0) then + local fennel_path = _1_0 return include_path(ast, opts, fennel_path, mod, true) else - local _ = _0_0 + local _ = _1_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -1123,15 +1723,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end end - return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _1_()) + return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _2_()) end end doc_special("include", {"module-name-literal"}, "Like require but load the target module during compilation and embed it in the\nLua output. The module must be a string literal and resolvable at compile time.") local function eval_compiler_2a(ast, scope, parent) - local scope0 = compiler["make-scope"](compiler.scopes.compiler) - local luasrc = compiler.compile(ast, {scope = scope0, useMetadata = utils.root.options.useMetadata}) - local loader = load_code(luasrc, wrap_env(make_compiler_env(ast, scope0, parent))) - return loader() + local env = make_compiler_env(ast, scope, parent) + local opts = utils.copy(utils.root.options) + opts.scope = compiler["make-scope"](compiler.scopes.compiler) + opts.allowedGlobals = macro_globals(env, current_global_names()) + return load_code(compiler.compile(ast, opts), wrap_env(env))(opts["module-name"], ast.filename) end SPECIALS.macros = function(ast, scope, parent) compiler.assert((#ast == 2), "Expected one table argument", ast) @@ -1152,7 +1753,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local utils = require("fennel.utils") local parser = require("fennel.parser") local friend = require("fennel.friend") - local unpack = (_G.unpack or table.unpack) + local unpack = (table.unpack or _G.unpack) local scopes = {} local function make_scope(parent) local parent0 = (parent or scopes.global) @@ -1164,6 +1765,27 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return {autogensyms = {}, depth = _0_, hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)} end + local function assert_msg(ast, msg) + local ast_tbl = nil + if ("table" == type(ast)) then + ast_tbl = ast + else + ast_tbl = {} + end + local m = getmetatable(ast) + local filename = ((m and m.filename) or ast_tbl.filename or "unknown") + local line = ((m and m.line) or ast_tbl.line or "?") + local target = nil + local function _1_() + if utils["sym?"](ast_tbl[1]) then + return utils.deref(ast_tbl[1]) + else + return (ast_tbl[1] or "()") + end + end + target = tostring(_1_()) + return string.format("Compile error in '%s' %s:%s: %s", target, filename, line, msg) + end local function assert_compile(condition, msg, ast) if not condition then local _0_ = (utils.root.options or {}) @@ -1171,19 +1793,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local unfriendly = _0_["unfriendly"] utils.root.reset() if unfriendly then - local m = getmetatable(ast) - local filename = ((m and m.filename) or ast.filename or "unknown") - local line = ((m and m.line) or ast.line or "?") - local target = nil - local function _1_() - if utils["is-sym"](ast[1]) then - return utils.deref(ast[1]) - else - return (ast[1] or "()") - end - end - target = tostring(_1_()) - error(string.format("Compile error in '%s' %s:%s: %s", target, filename, line, msg), 0) + error(assert_msg(ast, msg), 0) else friend["assert-compile"](condition, msg, ast, source) end @@ -1199,27 +1809,27 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function _0_(_241) return ("\\" .. _241:byte()) end - return ("%q"):format(str):gsub(".", serialize_subst):gsub("[\128-\255]", _0_) + return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _0_) end local function global_mangling(str) - if utils["is-valid-lua-identifier"](str) then + if utils["valid-lua-identifier?"](str) then return str else local function _0_(_241) - return ("_%02x"):format(_241:byte()) + return string.format("_%02x", _241:byte()) end return ("__fnl_global__" .. str:gsub("[^%w]", _0_)) end end local function global_unmangling(identifier) - local _0_0 = identifier:match("^__fnl_global__(.*)$") + local _0_0 = string.match(identifier, "^__fnl_global__(.*)$") if (nil ~= _0_0) then local rest = _0_0 local _1_0 = nil local function _2_(_241) return string.char(tonumber(_241:sub(2), 16)) end - _1_0 = rest:gsub("_[%da-f][%da-f]", _2_) + _1_0 = string.gsub(rest, "_[%da-f][%da-f]", _2_) return _1_0 else local _ = _0_0 @@ -1228,40 +1838,35 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local allowed_globals = nil local function global_allowed(name) - local found_3f = not allowed_globals - if not allowed_globals then - return true + return (not allowed_globals or utils["member?"](name, allowed_globals)) + end + local function unique_mangling(original, mangling, scope, append) + if scope.unmanglings[mangling] then + return unique_mangling(original, (original .. append), scope, (append + 1)) else - for _, g in ipairs(allowed_globals) do - if (g == name) then - found_3f = true - end - end - return found_3f + return mangling end end local function local_mangling(str, scope, ast, temp_manglings) - local append = 0 - local mangling = str - assert_compile(not utils["is-multi-sym"](str), ("unexpected multi symbol " .. str), ast) - if (utils["lua-keywords"][mangling] or mangling:match("^%d")) then - mangling = ("_" .. mangling) + assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast) + local raw = nil + if (utils["lua-keywords"][str] or str:match("^%d")) then + raw = ("_" .. str) + else + raw = str end + local mangling = nil local function _1_(_241) - return ("_%02x"):format(_241:byte()) + return string.format("_%02x", _241:byte()) end - mangling = mangling:gsub("-", "_"):gsub("[^%w_]", _1_) - local raw = mangling - while scope.unmanglings[mangling] do - mangling = (raw .. append) - append = (append + 1) - end - scope.unmanglings[mangling] = str + mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _1_) + local unique = unique_mangling(mangling, mangling, scope, 0) + scope.unmanglings[unique] = str do local manglings = (temp_manglings or scope.manglings) - manglings[str] = mangling + manglings[str] = unique end - return mangling + return unique end local function apply_manglings(scope, new_manglings, ast) for raw, mangled in pairs(new_manglings) do @@ -1272,8 +1877,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function combine_parts(parts, scope) local ret = (scope.manglings[parts[1]] or global_mangling(parts[1])) - for i = 2, #parts, 1 do - if utils["is-valid-lua-identifier"](parts[i]) then + for i = 2, #parts do + if utils["valid-lua-identifier?"](parts[i]) then if (parts["multi-sym-method-call"] and (i == #parts)) then ret = (ret .. ":" .. parts[i]) else @@ -1291,11 +1896,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct mangling = ((base or "") .. "_" .. append .. "_") append = (append + 1) end - scope.unmanglings[mangling] = true + scope.unmanglings[mangling] = (base or true) return mangling end local function autogensym(base, scope) - local _0_0 = utils["is-multi-sym"](base) + local _0_0 = utils["multi-sym?"](base) if (nil ~= _0_0) then local parts = _0_0 parts[1] = autogensym(parts[1], scope) @@ -1310,40 +1915,48 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return (scope.autogensyms[base] or _1_()) end end + local already_warned = {} local function check_binding_valid(symbol, scope, ast) local name = utils.deref(symbol) + if (io and io.stderr and name:find("&") and not already_warned[symbol]) then + already_warned[symbol] = true + do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. symbol.filename .. ":" .. symbol.line .. "\n")) + end assert_compile(not (scope.specials[name] or scope.macros[name]), ("local %s was overshadowed by a special form or macro"):format(name), ast) - return assert_compile(not utils["is-quoted"](symbol), ("macro tried to bind %s without gensym"):format(name), symbol) + return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) end local function declare_local(symbol, meta, scope, ast, temp_manglings) check_binding_valid(symbol, scope, ast) local name = utils.deref(symbol) - assert_compile(not utils["is-multi-sym"](name), ("unexpected multi symbol " .. name), ast) + assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast) scope.symmeta[name] = meta return local_mangling(name, scope, ast, temp_manglings) end - local function symbol_to_expression(symbol, scope, is_reference) - local name = symbol[1] - local multi_sym_parts = utils["is-multi-sym"](name) - if scope.hashfn then - if (name == "$") then - name = "$1" - end - if multi_sym_parts then - if (multi_sym_parts[1] == "$") then - multi_sym_parts[1] = "$1" - name = table.concat(multi_sym_parts, ".") - end + local function hashfn_arg_name(name, multi_sym_parts, scope) + if not scope.hashfn then + return nil + elseif (name == "$") then + return "$1" + elseif multi_sym_parts then + if (multi_sym_parts and (multi_sym_parts[1] == "$")) then + multi_sym_parts[1] = "$1" end + return table.concat(multi_sym_parts, ".") end - local parts = (multi_sym_parts or {name}) + end + local function symbol_to_expression(symbol, scope, reference_3f) + utils.hook("symbol-to-expression", symbol, scope, reference_3f) + local name = symbol[1] + local multi_sym_parts = utils["multi-sym?"](name) + local name0 = (hashfn_arg_name(name, multi_sym_parts, scope) or name) + local parts = (multi_sym_parts or {name0}) local etype = (((#parts > 1) and "expression") or "sym") - local is_local = scope.manglings[parts[1]] - if (is_local and scope.symmeta[parts[1]]) then + local local_3f = scope.manglings[parts[1]] + if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true end - assert_compile((not is_reference or is_local or global_allowed(parts[1])), ("unknown global in strict mode: " .. parts[1]), symbol) - if (allowed_globals and not is_local) then + assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. parts[1]), symbol) + if (allowed_globals and not local_3f) then utils.root.scope.refedglobals[parts[1]] = true end return utils.expr(combine_parts(parts, scope), etype) @@ -1361,10 +1974,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif ((#chunk >= 3) and (chunk[(#chunk - 2)].leaf == "do") and not chunk[(#chunk - 1)].leaf and (chunk[#chunk].leaf == "end")) then local kid = peephole(chunk[(#chunk - 1)]) local new_chunk = {ast = chunk.ast} - for i = 1, (#chunk - 3), 1 do + for i = 1, (#chunk - 3) do table.insert(new_chunk, peephole(chunk[i])) end - for i = 1, #kid, 1 do + for i = 1, #kid do table.insert(new_chunk, kid[i]) end return new_chunk @@ -1403,7 +2016,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local code = chunk.leaf local info = chunk.ast if sm then - sm[(#sm + 1)] = ((info and info.line) or ( - 1)) + table.insert(sm, ((info and info.line) or ( - 1))) end return code else @@ -1426,9 +2039,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if (c.leaf or (#c > 0)) then local sub = flatten_chunk(sm, c, tab0, (depth + 1)) if (depth > 0) then - sub = (tab0 .. sub:gsub("\n", ("\n" .. tab0))) + return (tab0 .. sub:gsub("\n", ("\n" .. tab0))) + else + return sub end - return sub end end return table.concat(utils.map(chunk, parter), "\n") @@ -1451,17 +2065,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local sm = {} local ret = flatten_chunk(sm, chunk0, options.indent, 0) if sm then - local key, short_src = nil + sm.short_src = make_short_src((options.filename or options.source or ret)) if options.filename then - short_src = options.filename - key = ("@" .. short_src) + sm.key = ("@" .. options.filename) else - key = ret - short_src = make_short_src((options.source or ret)) + sm.key = ret end - sm.short_src = short_src - sm.key = key - fennel_sourcemap[key] = sm + fennel_sourcemap[sm.key] = sm end return ret, sm end @@ -1496,10 +2106,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function keep_side_effects(exprs, chunk, start, ast) local start0 = (start or 1) - for j = start0, #exprs, 1 do + for j = start0, #exprs do local se = exprs[j] if ((se.type == "expression") and (se[1] ~= "nil")) then - emit(chunk, ("do local _ = %s end"):format(tostring(se)), ast) + emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then local code = tostring(se) emit(chunk, (((code:byte() == 40) and ("do end " .. code)) or code), ast) @@ -1514,49 +2124,60 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if (n ~= len) then if (len > n) then keep_side_effects(exprs, parent, (n + 1), ast) - for i = (n + 1), len, 1 do + for i = (n + 1), len do exprs[i] = nil end else - for i = (#exprs + 1), n, 1 do + for i = (#exprs + 1), n do exprs[i] = utils.expr("nil", "literal") end end end end if opts.tail then - emit(parent, ("return %s"):format(exprs1(exprs)), ast) + emit(parent, string.format("return %s", exprs1(exprs)), ast) end if opts.target then local result = exprs1(exprs) - if (result == "") then - result = "nil" + local function _2_() + if (result == "") then + return "nil" + else + return result + end end - emit(parent, ("%s = %s"):format(opts.target, result), ast) + emit(parent, string.format("%s = %s", opts.target, _2_()), ast) end if (opts.tail or opts.target) then - return {} + return {returned = true} else - return exprs + local _3_0 = exprs + _3_0["returned"] = true + return _3_0 + end + end + local function find_macro(ast, scope, multi_sym_parts) + local function find_in_table(t, i) + if (i <= #multi_sym_parts) then + return find_in_table((utils["table?"](t) and t[multi_sym_parts[i]]), (i + 1)) + else + return t + end + end + local macro_2a = (utils["sym?"](ast[1]) and scope.macros[utils.deref(ast[1])]) + if (not macro_2a and multi_sym_parts) then + local nested_macro = find_in_table(scope.macros, 1) + assert_compile((not scope.macros[multi_sym_parts[1]] or (type(nested_macro) == "function")), "macro not found in imported macro module", ast) + return nested_macro + else + return macro_2a end end local function macroexpand_2a(ast, scope, once) - if not utils["is-list"](ast) then + if not utils["list?"](ast) then return ast else - local multi_sym_parts = utils["is-multi-sym"](ast[1]) - local macro_2a = (utils["is-sym"](ast[1]) and scope.macros[utils.deref(ast[1])]) - if (not macro_2a and multi_sym_parts) then - local in_macro_module = nil - macro_2a = scope.macros - for i = 1, #multi_sym_parts, 1 do - macro_2a = (utils["is-table"](macro_2a) and macro_2a[multi_sym_parts[i]]) - if macro_2a then - in_macro_module = true - end - end - assert_compile((not in_macro_module or (type(macro_2a) == "function")), "macro not found in imported macro module", ast) - end + local macro_2a = find_macro(ast, scope, utils["multi-sym?"](ast[1])) if not macro_2a then return ast else @@ -1575,117 +2196,177 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end end + local function compile_special(ast, scope, parent, opts, special) + local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal")) + local exprs0 = nil + if (type(exprs) == "string") then + exprs0 = utils.expr(exprs, "expression") + else + exprs0 = exprs + end + local exprs2 = nil + if utils["expr?"](exprs0) then + exprs2 = {exprs0} + else + exprs2 = exprs0 + end + if not exprs2.returned then + return handle_compile_opts(exprs2, parent, opts, ast) + elseif (opts.tail or opts.target) then + return {returned = true} + else + return exprs2 + end + end + local function compile_function_call(ast, scope, parent, opts, compile1, len) + local fargs = {} + local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1] + assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast) + for i = 2, len do + local subexprs = nil + local _0_ + if (i ~= len) then + _0_ = 1 + else + _0_ = nil + end + subexprs = compile1(ast[i], scope, parent, {nval = _0_}) + table.insert(fargs, (subexprs[1] or utils.expr("nil", "literal"))) + if (i == len) then + for j = 2, #subexprs do + table.insert(fargs, subexprs[j]) + end + else + keep_side_effects(subexprs, parent, 2, ast[i]) + end + end + local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs)) + return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast) + end + local function compile_call(ast, scope, parent, opts, compile1) + utils.hook("call", ast, scope) + local len = #ast + local first = ast[1] + local multi_sym_parts = utils["multi-sym?"](first) + local special = (utils["sym?"](first) and scope.specials[utils.deref(first)]) + assert_compile((len > 0), "expected a function, macro, or special to call", ast) + if special then + return compile_special(ast, scope, parent, opts, special) + elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then + local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".") + local method_to_call = multi_sym_parts[#multi_sym_parts] + local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, select(2, unpack(ast))) + return compile1(new_ast, scope, parent, opts) + else + return compile_function_call(ast, scope, parent, opts, compile1, len) + end + end + local function compile_varg(ast, scope, parent, opts) + assert_compile(scope.vararg, "unexpected vararg", ast) + return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast) + end + local function compile_sym(ast, scope, parent, opts) + local multi_sym_parts = utils["multi-sym?"](ast) + assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast) + local e = nil + if (ast[1] == "nil") then + e = utils.expr("nil", "literal") + else + e = symbol_to_expression(ast, scope, true) + end + return handle_compile_opts({e}, parent, opts, ast) + end + local function serialize_number(n) + local _0_0, _1_0, _2_0 = math.modf(n) + if ((nil ~= _0_0) and (_1_0 == 0)) then + local int = _0_0 + return tostring(int) + else + local _3_ + do + local frac = _1_0 + _3_ = (((_0_0 == 0) and (nil ~= _1_0)) and (frac < 0)) + end + if _3_ then + local frac = _1_0 + return ("-0." .. tostring(frac):gsub("^-?0.", "")) + elseif ((nil ~= _0_0) and (nil ~= _1_0)) then + local int = _0_0 + local frac = _1_0 + return (int .. "." .. tostring(frac):gsub("^-?0.", "")) + end + end + end + local function compile_scalar(ast, _scope, parent, opts) + local serialize = nil + do + local _0_0 = type(ast) + if (_0_0 == "nil") then + serialize = tostring + elseif (_0_0 == "boolean") then + serialize = tostring + elseif (_0_0 == "string") then + serialize = serialize_string + elseif (_0_0 == "number") then + serialize = serialize_number + else + serialize = nil + end + end + return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts) + end + local function compile_table(ast, scope, parent, opts, compile1) + local buffer = {} + for i = 1, #ast do + local nval = ((i ~= #ast) and 1) + table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval}))) + end + local function write_other_values(k) + if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (k > #ast)) then + if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then + return {k, k} + else + local _0_ = compile1(k, scope, parent, {nval = 1}) + local compiled = _0_[1] + local kstr = ("[" .. tostring(compiled) .. "]") + return {kstr, k} + end + end + end + do + local keys = nil + do + local _0_0 = utils.kvmap(ast, write_other_values) + local function _1_(a, b) + return (a[1] < b[1]) + end + table.sort(_0_0, _1_) + keys = _0_0 + end + local function _1_(k) + local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1]) + return string.format("%s = %s", k[1], v) + end + utils.map(keys, _1_, buffer) + end + return handle_compile_opts({utils.expr(("{" .. table.concat(buffer, ", ") .. "}"), "expression")}, parent, opts, ast) + end local function compile1(ast, scope, parent, opts) local opts0 = (opts or {}) local ast0 = macroexpand_2a(ast, scope) - local exprs = {} - if utils["is-list"](ast0) then - local len = #ast0 - local first = ast0[1] - local multi_sym_parts = utils["is-multi-sym"](first) - local special = (utils["is-sym"](first) and scope.specials[utils.deref(first)]) - assert_compile((#ast0 > 0), "expected a function, macro, or special to call", ast0) - if special then - exprs = (special(ast0, scope, parent, opts0) or utils.expr("nil", "literal")) - if (type(exprs) == "string") then - exprs = utils.expr(exprs, "expression") - end - if utils["is-expr"](exprs) then - exprs = {exprs} - end - if not exprs.returned then - exprs = handle_compile_opts(exprs, parent, opts0, ast0) - elseif (opts0.tail or opts0.target) then - exprs = {} - end - elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then - local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".") - local method_to_call = multi_sym_parts[#multi_sym_parts] - local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call) - for i = 2, len, 1 do - new_ast[(#new_ast + 1)] = ast0[i] - end - exprs = compile1(new_ast, scope, parent, opts0) - else - local fargs = {} - local fcallee = compile1(ast0[1], scope, parent, {nval = 1})[1] - assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast0[1])), ast0) - fcallee = tostring(fcallee) - for i = 2, len, 1 do - local subexprs = compile1(ast0[i], scope, parent, {nval = (((i ~= len) and 1) or nil)}) - fargs[(#fargs + 1)] = (subexprs[1] or utils.expr("nil", "literal")) - if (i == len) then - for j = 2, #subexprs, 1 do - fargs[(#fargs + 1)] = subexprs[j] - end - else - keep_side_effects(subexprs, parent, 2, ast0[i]) - end - end - local call = ("%s(%s)"):format(tostring(fcallee), exprs1(fargs)) - exprs = handle_compile_opts({utils.expr(call, "statement")}, parent, opts0, ast0) - end - elseif utils["is-varg"](ast0) then - assert_compile(scope.vararg, "unexpected vararg", ast0) - exprs = handle_compile_opts({utils.expr("...", "varg")}, parent, opts0, ast0) - elseif utils["is-sym"](ast0) then - local multi_sym_parts = utils["is-multi-sym"](ast0) - local e = nil - assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast0) - if (ast0[1] == "nil") then - e = utils.expr("nil", "literal") - else - e = symbol_to_expression(ast0, scope, true) - end - exprs = handle_compile_opts({e}, parent, opts0, ast0) - elseif ((type(ast0) == "nil") or (type(ast0) == "boolean")) then - exprs = handle_compile_opts({utils.expr(tostring(ast0), "literal")}, parent, opts0) - elseif (type(ast0) == "number") then - local n = ("%.17g"):format(ast0) - exprs = handle_compile_opts({utils.expr(n, "literal")}, parent, opts0) - elseif (type(ast0) == "string") then - local s = serialize_string(ast0) - exprs = handle_compile_opts({utils.expr(s, "literal")}, parent, opts0) + if utils["list?"](ast0) then + return compile_call(ast0, scope, parent, opts0, compile1) + elseif utils["varg?"](ast0) then + return compile_varg(ast0, scope, parent, opts0) + elseif utils["sym?"](ast0) then + return compile_sym(ast0, scope, parent, opts0) elseif (type(ast0) == "table") then - local buffer = {} - for i = 1, #ast0, 1 do - local nval = ((i ~= #ast0) and 1) - buffer[(#buffer + 1)] = exprs1(compile1(ast0[i], scope, parent, {nval = nval})) - end - local function write_other_values(k) - if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (k > #ast0)) then - if ((type(k) == "string") and utils["is-valid-lua-identifier"](k)) then - return {k, k} - else - local _0_ = compile1(k, scope, parent, {nval = 1}) - local compiled = _0_[1] - local kstr = ("[" .. tostring(compiled) .. "]") - return {kstr, k} - end - end - end - do - local keys = nil - do - local _0_0 = utils.kvmap(ast0, write_other_values) - local function _1_(a, b) - return (a[1] < b[1]) - end - table.sort(_0_0, _1_) - keys = _0_0 - end - local function _1_(k) - local v = tostring(compile1(ast0[k[2]], scope, parent, {nval = 1})[1]) - return ("%s = %s"):format(k[1], v) - end - utils.map(keys, _1_, buffer) - end - exprs = handle_compile_opts({utils.expr(("{" .. table.concat(buffer, ", ") .. "}"), "expression")}, parent, opts0, ast0) + return compile_table(ast0, scope, parent, opts0, compile1) + elseif ((type(ast0) == "nil") or (type(ast0) == "boolean") or (type(ast0) == "number") or (type(ast0) == "string")) then + return compile_scalar(ast0, scope, parent, opts0) else - assert_compile(false, ("could not compile value of type " .. type(ast0)), ast0) + return assert_compile(false, ("could not compile value of type " .. type(ast0)), ast0) end - exprs.returned = true - return exprs end local function destructure(to, from, ast, scope, parent, opts) local opts0 = (opts or {}) @@ -1696,6 +2377,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local isvar = _0_["isvar"] local nomulti = _0_["nomulti"] local noundef = _0_["noundef"] + local symtype = _0_["symtype"] + local symtype0 = ("_" .. (symtype or "dst")) local setter = nil if declaration then setter = "local %s = %s" @@ -1705,14 +2388,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local new_manglings = {} local function getname(symbol, up1) local raw = symbol[1] - assert_compile(not (nomulti and utils["is-multi-sym"](raw)), ("unexpected multi symbol " .. raw), up1) + assert_compile(not (nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1) if declaration then - return declare_local(symbol, {var = isvar}, scope, symbol, new_manglings) + return declare_local(symbol, nil, scope, symbol, new_manglings) else - local parts = (utils["is-multi-sym"](raw) or {raw}) + local parts = (utils["multi-sym?"](raw) or {raw}) local meta = scope.symmeta[parts[1]] if ((#parts == 1) and not forceset) then - assert_compile(not (forceglobal and meta), ("global %s conflicts with local"):format(tostring(symbol)), symbol) + assert_compile(not (forceglobal and meta), string.format("global %s conflicts with local", tostring(symbol)), symbol) assert_compile(not (meta and not meta.var), ("expected var " .. raw), symbol) assert_compile((meta or not noundef), ("expected local " .. parts[1]), symbol) end @@ -1755,81 +2438,112 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return ret end - local function destructure1(left, rightexprs, up1, top) - if (utils["is-sym"](left) and (left[1] ~= "nil")) then - local lname = getname(left, up1) - check_binding_valid(left, scope, left) - if top then - compile_top_target({lname}) + local function destructure_sym(left, rightexprs, up1, top_3f) + local lname = getname(left, up1) + check_binding_valid(left, scope, left) + if top_3f then + compile_top_target({lname}) + else + emit(parent, setter:format(lname, exprs1(rightexprs)), left) + end + if declaration then + scope.symmeta[utils.deref(left)] = {var = isvar} + return nil + end + end + local function destructure_table(left, rightexprs, top_3f, destructure1) + local s = gensym(scope, symtype0) + local right = nil + do + local _2_0 = nil + if top_3f then + _2_0 = exprs1(compile1(from, scope, parent)) else - emit(parent, setter:format(lname, exprs1(rightexprs)), left) + _2_0 = exprs1(rightexprs) end - elseif utils["is-table"](left) then - local s = gensym(scope) - local right = nil - if top then - right = exprs1(compile1(from, scope, parent)) - else - right = exprs1(rightexprs) - end - if (right == "") then + if (_2_0 == "") then right = "nil" + elseif (nil ~= _2_0) then + local right0 = _2_0 + right = right0 + else + right = nil end - emit(parent, ("local %s = %s"):format(s, right), left) - for k, v in utils.stablepairs(left) do - if (utils["is-sym"](left[k]) and (left[k][1] == "&")) then - assert_compile(((type(k) == "number") and not left[(k + 2)]), "expected rest argument before last parameter", left) - local formatted = ("{(table.unpack or unpack)(%s, %s)}"):format(s, k) + end + emit(parent, string.format("local %s = %s", s, right), left) + for k, v in utils.stablepairs(left) do + if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then + if (utils["sym?"](v) and (utils.deref(v) == "&")) then + local unpack_str = "{(table.unpack or unpack)(%s, %s)}" + local formatted = string.format(unpack_str, s, k) local subexpr = utils.expr(formatted, "expression") + assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left) destructure1(left[(k + 1)], {subexpr}, left) - return + elseif (utils["sym?"](k) and (utils.deref(k) == "&as")) then + destructure_sym(v, {utils.expr(tostring(s))}, left) + elseif (utils["sequence?"](left) and (utils.deref(v) == "&as")) then + local _, next_sym, trailing = select(k, unpack(left)) + assert_compile((nil == trailing), "expected &as argument before last parameter", left) + destructure_sym(next_sym, {utils.expr(tostring(s))}, left) else - if (utils["is-sym"](k) and (tostring(k) == ":") and utils["is-sym"](v)) then - k = tostring(v) + local key = nil + if (type(k) == "string") then + key = serialize_string(k) + else + key = k end - if (type(k) ~= "number") then - k = serialize_string(k) - end - local subexpr = utils.expr(("%s[%s]"):format(s, k), "expression") + local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression") destructure1(v, {subexpr}, left) end end - elseif utils["is-list"](left) then - local left_names, tables = {}, {} - for i, name in ipairs(left) do - local symname = nil - if utils["is-sym"](name) then - symname = getname(name, up1) - else - symname = gensym(scope) - tables[i] = {name, utils.expr(symname, "sym")} - end - table.insert(left_names, symname) - end - if top then - compile_top_target(left_names) - else - local lvalue = table.concat(left_names, ", ") - local setting = setter:format(lvalue, exprs1(rightexprs)) - emit(parent, setting, left) - end - for _, pair in utils.stablepairs(tables) do - destructure1(pair[1], {pair[2]}, left) - end - else - assert_compile(false, ("unable to bind %s %s"):format(type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1)) end - if top then + return nil + end + local function destructure_values(left, up1, top_3f, destructure1) + local left_names, tables = {}, {} + for i, name in ipairs(left) do + if utils["sym?"](name) then + table.insert(left_names, getname(name, up1)) + else + local symname = gensym(scope, symtype0) + table.insert(left_names, symname) + tables[i] = {name, utils.expr(symname, "sym")} + end + end + assert_compile(top_3f, "can't nest multi-value destructuring", left) + compile_top_target(left_names) + if declaration then + for _, sym in ipairs(left) do + scope.symmeta[utils.deref(sym)] = {var = isvar} + end + end + for _, pair in utils.stablepairs(tables) do + destructure1(pair[1], {pair[2]}, left) + end + return nil + end + local function destructure1(left, rightexprs, up1, top_3f) + if (utils["sym?"](left) and (left[1] ~= "nil")) then + destructure_sym(left, rightexprs, up1, top_3f) + elseif utils["table?"](left) then + destructure_table(left, rightexprs, top_3f, destructure1) + elseif utils["list?"](left) then + destructure_values(left, up1, top_3f, destructure1) + else + assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1)) + end + if top_3f then return {returned = true} end end local ret = destructure1(to, nil, ast, true) + utils.hook("destructure", from, to, scope) apply_manglings(scope, new_manglings, ast) return ret end local function require_include(ast, scope, parent, opts) opts.fallback = function(e) - return utils.expr(("require(%s)"):format(tostring(e)), "statement") + return utils.expr(string.format("require(%s)", tostring(e)), "statement") end return scopes.global.specials.include(ast, scope, parent, opts) end @@ -1849,10 +2563,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct scope.specials.require = require_include end utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts - for ok, val in parser.parser(strm, opts.filename, opts) do - vals[(#vals + 1)] = val + for _, val in parser.parser(strm, opts.filename, opts) do + table.insert(vals, val) end - for i = 1, #vals, 1 do + for i = 1, #vals do local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)}) keep_side_effects(exprs, chunk, nil, vals[i]) end @@ -1886,7 +2600,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function traceback_frame(info) if ((info.what == "C") and info.name) then - return (" [C]: in function '%s'"):format(info.name) + return string.format(" [C]: in function '%s'", info.name) elseif (info.what == "C") then return " [C]: in ?" else @@ -1913,7 +2627,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function traceback(msg, start) local msg0 = (msg or "") - if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on"]("trace")) then + if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then return msg0 else local lines = {} @@ -1969,47 +2683,47 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return ret end - local function do_quote(form, scope, parent, runtime) + local function do_quote(form, scope, parent, runtime_3f) local function q(x) - return do_quote(x, scope, parent, runtime) + return do_quote(x, scope, parent, runtime_3f) end - if utils["is-varg"](form) then - assert_compile(not runtime, "quoted ... may only be used at compile time", form) + if utils["varg?"](form) then + assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form) return "_VARARG" - elseif utils["is-sym"](form) then + elseif utils["sym?"](form) then local filename = nil if form.filename then - filename = ("%q"):format(form.filename) + filename = string.format("%q", form.filename) else filename = "nil" end local symstr = utils.deref(form) - assert_compile(not runtime, "symbols may only be used at compile time", form) + assert_compile(not runtime_3f, "symbols may only be used at compile time", form) if (symstr:find("#$") or symstr:find("#[:.]")) then - return ("sym('%s', nil, {filename=%s, line=%s})"):format(autogensym(symstr, scope), filename, (form.line or "nil")) + return string.format("sym('%s', nil, {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) else - return ("sym('%s', nil, {quoted=true, filename=%s, line=%s})"):format(symstr, filename, (form.line or "nil")) + return string.format("sym('%s', nil, {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil")) end - elseif (utils["is-list"](form) and utils["is-sym"](form[1]) and (utils.deref(form[1]) == "unquote")) then + elseif (utils["list?"](form) and utils["sym?"](form[1]) and (utils.deref(form[1]) == "unquote")) then local payload = form[2] local res = unpack(compile1(payload, scope, parent)) return res[1] - elseif utils["is-list"](form) then + elseif utils["list?"](form) then local mapped = utils.kvmap(form, entry_transform(no, q)) local filename = nil if form.filename then - filename = ("%q"):format(form.filename) + filename = string.format("%q", form.filename) else filename = "nil" end - assert_compile(not runtime, "lists may only be used at compile time", form) - return (("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(list()))")):format(filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", ")) + assert_compile(not runtime_3f, "lists may only be used at compile time", form) + 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, ", ")) elseif (type(form) == "table") then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) local filename = nil if source.filename then - filename = ("%q"):format(source.filename) + filename = string.format("%q", source.filename) else filename = "nil" end @@ -2020,7 +2734,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return "nil" end end - return ("setmetatable({%s}, {filename=%s, line=%s})"):format(mixed_concat(mapped, ", "), filename, _1_()) + return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _1_()) elseif (type(form) == "string") then return serialize_string(form) else @@ -2032,14 +2746,10 @@ end package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...) local function ast_source(ast) local m = getmetatable(ast) - if (m and m.line and m) then - return m - else - return ast - end + return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) end 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"}, ["could not compile value of type "] = {"debugging the macro you're calling not to return a coroutine or userdata"}, ["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 binding table"] = {"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 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 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"}, ["illegal 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"}, ["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"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["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 global in strict mode: (.*)"] = {"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 (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} - local unpack = (_G.unpack or table.unpack) + local unpack = (table.unpack or _G.unpack) local function suggest(msg) local suggestion = nil for pat, sug in pairs(suggestions) do @@ -2095,7 +2805,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( local bytestart = _1_["bytestart"] local filename = _1_["filename"] local line = _1_["line"] - local ok, codeline, bol, eol = pcall(read_line, filename, line, source) + local ok, codeline, bol = pcall(read_line, filename, line, source) local suggestions0 = suggest(msg) local out = {msg, ""} if (ok and codeline) then @@ -2132,25 +2842,32 @@ end package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(...) local utils = require("fennel.utils") local friend = require("fennel.friend") - local unpack = (_G.unpack or table.unpack) + local unpack = (table.unpack or _G.unpack) local function granulate(getchunk) - local c = "" - local index = 1 - local done = false + local c, index, done_3f = "", 1, false local function _0_(parser_state) - if not done then + if not done_3f then if (index <= #c) then local b = c:byte(index) index = (index + 1) return b else - c = getchunk(parser_state) - if (not c or (c == "")) then - done = true + local _1_0, _2_0, _3_0 = getchunk(parser_state) + local _4_ + do + local char = _1_0 + _4_ = ((nil ~= _1_0) and (char ~= "")) + end + if _4_ then + local char = _1_0 + c = char + index = 2 + return c:byte() + else + local _ = _1_0 + done_3f = true return nil end - index = 2 - return c:byte(1) end end end @@ -2161,7 +2878,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return _0_, _1_ end local function string_stream(str) - local str0 = str:gsub("^#![^\n]*\n", "") + local str0 = str:gsub("^#!", ";;") local index = 1 local function _0_() local r = str0:byte(index) @@ -2171,11 +2888,17 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return _0_ end local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true} - local function iswhitespace(b) + local function whitespace_3f(b) return ((b == 32) or ((b >= 9) and (b <= 13))) end - local function issymbolchar(b) - return ((b > 32) and not delims[b] and (b ~= 127) and (b ~= 34) and (b ~= 39) and (b ~= 126) and (b ~= 59) and (b ~= 44) and (b ~= 64) and (b ~= 96)) + local function sym_char_3f(b) + local b0 = nil + if ("number" == type(b)) then + b0 = b + else + b0 = string.byte(b) + end + return ((b0 > 32) and not delims[b0] and (b0 ~= 127) and (b0 ~= 34) and (b0 ~= 39) and (b0 ~= 126) and (b0 ~= 59) and (b0 ~= 44) and (b0 ~= 64) and (b0 ~= 96)) end local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"} local function parser(getbyte, filename, options) @@ -2204,200 +2927,247 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return r end - local function parse_error(msg) - local _0_ = (utils.root.options or {}) + local function parse_error(msg, byteindex_override) + local _0_ = (options or utils.root.options or {}) local source = _0_["source"] local unfriendly = _0_["unfriendly"] utils.root.reset() if unfriendly then - return error(("Parse error in %s:%s: %s"):format((filename or "unknown"), (line or "?"), msg), 0) + return error(string.format("Parse error in %s:%s: %s", (filename or "unknown"), (line or "?"), msg), 0) else - return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), byteindex, source) + return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), (byteindex_override or byteindex), source) end end local function parse_stream() - local whitespace_since_dispatch, done, retval = true + local whitespace_since_dispatch, done_3f, retval = true local function dispatch(v) - if (#stack == 0) then - retval = v - done = true - whitespace_since_dispatch = false + local _0_0 = stack[#stack] + if (_0_0 == nil) then + retval, done_3f, whitespace_since_dispatch = v, true, false return nil - elseif stack[#stack].prefix then - local stacktop = stack[#stack] - stack[#stack] = nil - return dispatch(utils.list(utils.sym(stacktop.prefix), v)) - else + elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then + local prefix = _0_0.prefix + table.remove(stack) + return dispatch(utils.list(utils.sym(prefix), v)) + elseif (nil ~= _0_0) then + local top = _0_0 whitespace_since_dispatch = false - return table.insert(stack[#stack], v) + return table.insert(top, v) end end local function badend() local accum = utils.map(stack, "closer") - return parse_error(("expected closing delimiter%s %s"):format((((#stack == 1) and "") or "s"), string.char(unpack(accum)))) + local _0_ + if (#stack == 1) then + _0_ = "" + else + _0_ = "s" + end + return parse_error(string.format("expected closing delimiter%s %s", _0_, string.char(unpack(accum)))) end - while true do - local b = nil - while true do - b = getb() - if (b and iswhitespace(b)) then - whitespace_since_dispatch = true - end - if (not b or not iswhitespace(b)) then - break - end + local function skip_whitespace(b) + if (b and whitespace_3f(b)) then + whitespace_since_dispatch = true + return skip_whitespace(getb()) + elseif (not b and (#stack > 0)) then + return badend() + else + return b end - if not b then - if (#stack > 0) then - badend() + end + local function parse_comment(b, contents) + if (b and (10 ~= b)) then + local function _1_() + local _0_0 = contents + table.insert(_0_0, string.char(b)) + return _0_0 end - return nil + return parse_comment(getb(), _1_()) + elseif (options and options.comments) then + return dispatch(utils.comment(table.concat(contents))) + else + return b end - if (b == 59) then - while true do - b = getb() - if (not b or (b == 10)) then - break - end + end + local function open_table(b) + if not whitespace_since_dispatch then + parse_error(("expected whitespace before opening delimiter " .. string.char(b))) + end + return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line}) + end + local function close_list(list) + return dispatch(setmetatable(list, getmetatable(utils.list()))) + end + local function close_sequence(tbl) + local val = utils.sequence(unpack(tbl)) + for k, v in pairs(tbl) do + getmetatable(val)[k] = v + end + return dispatch(val) + end + local function close_curly_table(tbl) + local val = {} + if ((#tbl % 2) ~= 0) then + byteindex = (byteindex - 1) + parse_error("expected even number of values in table literal") + end + setmetatable(val, tbl) + for i = 1, #tbl, 2 do + if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then + tbl[i] = tostring(tbl[(i + 1)]) end - elseif (type(delims[b]) == "number") then - if not whitespace_since_dispatch then - parse_error(("expected whitespace before opening delimiter " .. string.char(b))) - end - table.insert(stack, setmetatable({bytestart = byteindex, closer = delims[b], filename = filename, line = line}, getmetatable(utils.list()))) - elseif delims[b] then - if (#stack == 0) then - parse_error(("unexpected closing delimiter " .. string.char(b))) - end - local last = stack[#stack] - local val = nil - if (last.closer ~= b) then - parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(last.closer))) - end - last.byteend = byteindex - if (b == 41) then - val = last - elseif (b == 93) then - val = utils.sequence(unpack(last)) - for k, v in pairs(last) do - getmetatable(val)[k] = v - end + val[tbl[i]] = tbl[(i + 1)] + end + return dispatch(val) + end + local function close_table(b) + local top = table.remove(stack) + if (top == nil) then + parse_error(("unexpected closing delimiter " .. string.char(b))) + end + if (top.closer ~= b) then + parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) + end + top.byteend = byteindex + if (b == 41) then + return close_list(top) + elseif (b == 93) then + return close_sequence(top) + else + return close_curly_table(top) + end + end + local function parse_string_loop(chars, b, state) + table.insert(chars, b) + local state0 = nil + do + local _0_0 = {state, b} + if ((type(_0_0) == "table") and (_0_0[1] == "base") and (_0_0[2] == 92)) then + state0 = "backslash" + elseif ((type(_0_0) == "table") and (_0_0[1] == "base") and (_0_0[2] == 34)) then + state0 = "done" else - if ((#last % 2) ~= 0) then - byteindex = (byteindex - 1) - parse_error("expected even number of values in table literal") - end - val = {} - setmetatable(val, last) - for i = 1, #last, 2 do - if ((tostring(last[i]) == ":") and utils["is-sym"](last[(i + 1)]) and utils["is-sym"](last[i])) then - last[i] = tostring(last[(i + 1)]) - end - val[last[i]] = last[(i + 1)] - end + local _ = _0_0 + state0 = "base" end - stack[#stack] = nil - dispatch(val) - elseif (b == 34) then - local state = "base" - local chars = {34} - stack[(#stack + 1)] = {closer = 34} - while true do - b = getb() - chars[(#chars + 1)] = b - if (state == "base") then - if (b == 92) then - state = "backslash" - elseif (b == 34) then - state = "done" - end - else - state = "base" - end - if (not b or (state == "done")) then - break - end - end - if not b then - badend() - end - stack[#stack] = nil - local raw = string.char(unpack(chars)) - local formatted = nil - local function _2_(c) - return ("\\" .. c:byte()) - end - formatted = raw:gsub("[\1-\31]", _2_) - local load_fn = (_G.loadstring or load)(("return %s"):format(formatted)) - dispatch(load_fn()) - elseif prefixes[b] then - table.insert(stack, {prefix = prefixes[b]}) - local nextb = getb() - if iswhitespace(nextb) then - if (b ~= 35) then - parse_error("invalid whitespace after quoting prefix") - end - stack[#stack] = nil - dispatch(utils.sym("#")) - end - ungetb(nextb) - elseif (issymbolchar(b) or (b == string.byte("~"))) then - local chars = {} - local bytestart = byteindex - while true do - chars[(#chars + 1)] = b - b = getb() - if (not b or not issymbolchar(b)) then - break - end + end + if (b and (state0 ~= "done")) then + return parse_string_loop(chars, getb(), state0) + else + return b + end + end + local function escape_char(c) + return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()] + end + local function parse_string() + table.insert(stack, {closer = 34}) + local chars = {34} + if not parse_string_loop(chars, getb(), "base") then + badend() + end + table.remove(stack) + local raw = string.char(unpack(chars)) + local formatted = raw:gsub("[\7-\13]", escape_char) + local load_fn = (rawget(_G, "loadstring") or load)(("return " .. formatted)) + return dispatch(load_fn()) + end + local function parse_prefix(b) + table.insert(stack, {prefix = prefixes[b]}) + local nextb = getb() + if whitespace_3f(nextb) then + if (b ~= 35) then + parse_error("invalid whitespace after quoting prefix") end + table.remove(stack) + dispatch(utils.sym("#")) + end + return ungetb(nextb) + end + local function parse_sym_loop(chars, b) + if (b and sym_char_3f(b)) then + table.insert(chars, b) + return parse_sym_loop(chars, getb()) + else 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(utils.varg()) - elseif rawstr:match("^:.+$") then - dispatch(rawstr:sub(2)) - elseif (rawstr:match("^~") and (rawstr ~= "~=")) then - parse_error("illegal character: ~") - else - local force_number = rawstr:match("^%d") - local number_with_stripped_underscores = rawstr:gsub("_", "") - local x = nil - if force_number then - x = (tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\""))) - else - x = tonumber(number_with_stripped_underscores) - if not x then - if rawstr:match("%.[0-9]") then - byteindex = (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1) - parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr)) - elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then - byteindex = ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]")) - parse_error(("malformed multisym: " .. rawstr)) - elseif rawstr:match(":.+[%.:]") then - byteindex = ((byteindex - #rawstr) + rawstr:find(":.+[%.:]")) - parse_error(("method must be last component " .. "of multisym: " .. rawstr)) - else - x = utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line}) - end - end - end + return chars + end + end + local function parse_number(rawstr) + local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", "")) + if rawstr:match("^%d") then + dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))) + return true + else + local _0_0 = tonumber(number_with_stripped_underscores) + if (nil ~= _0_0) then + local x = _0_0 dispatch(x) + return true + else + local _ = _0_0 + return false end + end + end + local function check_malformed_sym(rawstr) + if (rawstr:match("^~") and (rawstr ~= "~=")) then + return parse_error("illegal character: ~") + elseif rawstr:match("%.[0-9]") then + return parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr), (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1)) + elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then + return parse_error(("malformed multisym: " .. rawstr), ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]"))) + elseif rawstr:match(":.+[%.:]") then + return parse_error(("method must be last component " .. "of multisym: " .. rawstr), ((byteindex - #rawstr) + rawstr:find(":.+[%.:]"))) + end + end + local function parse_sym(b) + local bytestart = byteindex + local rawstr = string.char(unpack(parse_sym_loop({b}, getb()))) + if (rawstr == "true") then + return dispatch(true) + elseif (rawstr == "false") then + return dispatch(false) + elseif (rawstr == "...") then + return dispatch(utils.varg()) + elseif rawstr:match("^:.+$") then + return dispatch(rawstr:sub(2)) + elseif parse_number(rawstr) then + return nil + elseif check_malformed_sym(rawstr) then + return nil + else + return dispatch(utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line})) + end + end + local function parse_loop(b) + if not b then + elseif (b == 59) then + parse_comment(getb(), {";"}) + elseif (type(delims[b]) == "number") then + open_table(b) + elseif delims[b] then + close_table(b) + elseif (b == 34) then + parse_string(b) + elseif prefixes[b] then + parse_prefix(b) + elseif (sym_char_3f(b) or (b == string.byte("~"))) then + parse_sym(b) else parse_error(("illegal character: " .. string.char(b))) end - if done then - break + if not b then + return nil + elseif done_3f then + return true, retval + else + return parse_loop(skip_whitespace(getb())) end end - return true, retval + return parse_loop(skip_whitespace(getb())) end local function _0_() stack = {} @@ -2405,7 +3175,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return parse_stream, _0_ end - return {["string-stream"] = string_stream, granulate = granulate, parser = parser} + return {["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f, granulate = granulate, parser = parser} end local utils = nil package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...) @@ -2426,7 +3196,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (idx == nil) then return keys[1], tbl[keys[1]] else - return succ[idx], tbl[succ[idx]] + return succ[idx], succ[idx] and tbl[succ[idx]] end end return stablenext, t, nil @@ -2465,22 +3235,35 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. f0 = _0_ end for k, x in stablepairs(t) do - local korv, v = f0(k, x) - if (korv and not v) then - table.insert(out0, korv) - end - if (korv and v) then - out0[korv] = v + local _1_0, _2_0 = f0(k, x) + if ((nil ~= _1_0) and (nil ~= _2_0)) then + local key = _1_0 + local value = _2_0 + out0[key] = value + elseif (nil ~= _1_0) then + local value = _1_0 + table.insert(out0, value) end end return out0 end - local function copy(from) - local to = {} + local function copy(from, to) + local to0 = (to or {}) for k, v in pairs((from or {})) do - to[k] = v + to0[k] = v + end + return to0 + end + local function member_3f(x, tbl, n) + local _0_0 = tbl[(n or 1)] + if (_0_0 == x) then + return true + elseif (_0_0 == nil) then + return false + else + local _ = _0_0 + return member_3f(x, tbl, ((n or 1) + 1)) end - return to end local function allpairs(tbl) assert((type(tbl) == "table"), "allpairs expects a table") @@ -2507,34 +3290,35 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return self[1] end local nil_sym = nil - local function list_to_string(self, tostring2) + local function list__3estring(self, tostring2) local safe, max = {}, 0 for k in pairs(self) do if ((type(k) == "number") and (k > max)) then max = k end end - for i = 1, max, 1 do + for i = 1, max do safe[i] = (((self[i] == nil) and nil_sym) or self[i]) end return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")") end - local SYMBOL_MT = {"SYMBOL", __fennelview = deref, __tostring = deref} - local EXPR_MT = {"EXPR", __tostring = deref} - local LIST_MT = {"LIST", __fennelview = list_to_string, __tostring = list_to_string} - local SEQUENCE_MARKER = {"SEQUENCE"} - local VARARG = setmetatable({"..."}, {"VARARG", __fennelview = deref, __tostring = deref}) + local symbol_mt = {"SYMBOL", __fennelview = deref, __tostring = deref} + local expr_mt = {"EXPR", __tostring = deref} + local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} + local comment_mt = {"COMMENT", __fennelview = deref, __tostring = deref} + local sequence_marker = {"SEQUENCE"} + local vararg = setmetatable({"..."}, {"VARARG", __fennelview = deref, __tostring = deref}) local getenv = nil local function _0_() return nil end getenv = ((os and os.getenv) or _0_) - local function debug_on(flag) + local function debug_on_3f(flag) local level = (getenv("FENNEL_DEBUG") or "") return ((level == "all") or level:find(flag)) end local function list(...) - return setmetatable({...}, LIST_MT) + return setmetatable({...}, list_mt) end local function sym(str, scope, source) local s = {str, scope = scope} @@ -2543,40 +3327,46 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. s[k] = v end end - return setmetatable(s, SYMBOL_MT) + return setmetatable(s, symbol_mt) end nil_sym = sym("nil") local function sequence(...) - return setmetatable({...}, {sequence = SEQUENCE_MARKER}) + return setmetatable({...}, {sequence = sequence_marker}) end local function expr(strcode, etype) - return setmetatable({strcode, type = etype}, EXPR_MT) + return setmetatable({strcode, type = etype}, expr_mt) + end + local function comment_2a(contents) + return setmetatable({contents}, comment_mt) end local function varg() - return VARARG + return vararg end - local function is_expr(x) - return ((type(x) == "table") and (getmetatable(x) == EXPR_MT) and x) + local function expr_3f(x) + return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x) end - local function is_varg(x) - return ((x == VARARG) and x) + local function varg_3f(x) + return ((x == vararg) and x) end - local function is_list(x) - return ((type(x) == "table") and (getmetatable(x) == LIST_MT) and x) + local function list_3f(x) + return ((type(x) == "table") and (getmetatable(x) == list_mt) and x) end - local function is_sym(x) - return ((type(x) == "table") and (getmetatable(x) == SYMBOL_MT) and x) + local function sym_3f(x) + return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and x) end - local function is_table(x) - return ((type(x) == "table") and (x ~= VARARG) and (getmetatable(x) ~= LIST_MT) and (getmetatable(x) ~= SYMBOL_MT) and x) + local function table_3f(x) + return ((type(x) == "table") and (x ~= vararg) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and x) end - local function is_sequence(x) + local function sequence_3f(x) local mt = ((type(x) == "table") and getmetatable(x)) - return (mt and (mt.sequence == SEQUENCE_MARKER) and x) + return (mt and (mt.sequence == sequence_marker) and x) end - local function is_multi_sym(str) - if is_sym(str) then - return is_multi_sym(tostring(str)) + local function comment_3f(x) + return ((type(x) == "table") and (getmetatable(x) == comment_mt) and x) + end + local function multi_sym_3f(str) + if sym_3f(str) then + return multi_sym_3f(tostring(str)) elseif (type(str) ~= "string") then return false else @@ -2595,7 +3385,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return ((#parts > 0) and (str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and parts) end end - local function is_quoted(symbol) + local function quoted_3f(symbol) return symbol.quoted end local function walk_tree(root, f, custom_iterator) @@ -2610,14 +3400,14 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. walk((custom_iterator or pairs), nil, nil, root) return root end - local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while"} + local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while", "goto"} for i, v in ipairs(lua_keywords) do lua_keywords[v] = i end - local function is_valid_lua_identifier(str) + local function valid_lua_identifier_3f(str) return (str:match("^[%a_][%w_]*$") and not lua_keywords[str]) end - local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env"} + local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env", "compilerEnv"} local function propagate_options(options, subopts) for _, name in ipairs(propagated_options) do subopts[name] = options[name] @@ -2628,26 +3418,48 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function _1_() end root = {chunk = nil, options = nil, reset = _1_, scope = nil} - root["set-reset"] = function(new_root) + root["set-reset"] = function(_2_0) + local _3_ = _2_0 + local chunk = _3_["chunk"] + local options = _3_["options"] + local reset = _3_["reset"] + local scope = _3_["scope"] root.reset = function() - root.chunk, root.scope, root.options, root.reset = new_root.chunk, new_root.scope, new_root.options, new_root.reset + root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset return nil end return root.reset end - local _3_ - do - local _2_0 = {"./?.fnl", "./?/init.fnl"} - table.insert(_2_0, getenv("FENNEL_PATH")) - _3_ = _2_0 + local function hook(event, ...) + if (root.options and root.options.plugins) then + for _, plugin in ipairs(root.options.plugins) do + local _3_0 = plugin[event] + if (nil ~= _3_0) then + local f = _3_0 + f(...) + end + end + return nil + end end - return {["debug-on"] = debug_on, ["is-expr"] = is_expr, ["is-list"] = is_list, ["is-multi-sym"] = is_multi_sym, ["is-quoted"] = is_quoted, ["is-sequence"] = is_sequence, ["is-sym"] = is_sym, ["is-table"] = is_table, ["is-valid-lua-identifier"] = is_valid_lua_identifier, ["is-varg"] = is_varg, ["lua-keywords"] = lua_keywords, ["propagate-options"] = propagate_options, ["walk-tree"] = walk_tree, allpairs = allpairs, copy = copy, deref = deref, expr = expr, kvmap = kvmap, list = list, map = map, path = table.concat(_3_, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg} + return {["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["sequence?"] = sequence_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, deref = deref, expr = expr, hook = hook, kvmap = kvmap, list = list, map = map, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg} end utils = require("fennel.utils") local parser = require("fennel.parser") local compiler = require("fennel.compiler") local specials = require("fennel.specials") local repl = require("fennel.repl") +local view = require("fennel.view") +local function get_env(env) + if (env == "_COMPILER") then + local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + local mt = getmetatable(env0) + mt.__index = _G + return specials["wrap-env"](env0) + else + return (env and specials["wrap-env"](env)) + end +end local function eval(str, options, ...) local opts = utils.copy(options) local _ = nil @@ -2657,7 +3469,7 @@ local function eval(str, options, ...) else _ = nil end - local env = (opts.env and specials["wrap-env"](opts.env)) + local env = get_env(opts.env) local lua_source = compiler["compile-string"](str, opts) local loader = nil local function _1_(...) @@ -2674,17 +3486,24 @@ end local function dofile_2a(filename, options, ...) local opts = utils.copy(options) local f = assert(io.open(filename, "rb")) - local source = f:read("*all") + local source = assert(f:read("*all"), ("Could not read " .. filename)) f:close() opts.filename = filename return eval(source, opts, ...) end -local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["string-stream"] = parser["string-stream"], 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"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.5.0"} +local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], 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"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.8.0", view = view} utils["fennel-module"] = mod do - local builtin_macros = [===[;; The code for these macros is somewhat idiosyncratic because it cannot use any + local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other + ;; modules that are loaded by the old bootstrap compiler, this runs in the + ;; compiler scope of the version of the compiler being defined. + + ;; The code for these macros is somewhat idiosyncratic because it cannot use any ;; macros which have not yet been defined. + ;; TODO: some of these macros modify their arguments; we should stop doing that, + ;; but in a way that preserves file/line metadata. + (fn -> [val ...] "Thread-first macro. Take the first value and splice it into the second form as its first argument. @@ -2768,6 +3587,49 @@ do `(let ,closable-bindings ,closer (close-handlers# (xpcall ,bodyfn ,traceback))))) + (fn collect [iter-tbl key-value-expr ...] + "Returns a table made by running an iterator and evaluating an expression + that returns key-value pairs to be inserted sequentially into the table. + This can be thought of as a \"table comprehension\". The provided key-value + expression must return either 2 values, or nil. + + For example, + (collect [k v (pairs {:apple \"red\" :orange \"orange\"})] + (values v k)) + returns + {:red \"apple\" :orange \"orange\"}" + (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2)) + "expected iterator binding table") + (assert (not= nil key-value-expr) + "expected key-value expression") + (assert (= nil ...) + "expected exactly one body expression. Wrap multiple expressions with do") + `(let [tbl# {}] + (each ,iter-tbl + (match ,key-value-expr + (k# v#) (tset tbl# k# v#))) + tbl#)) + + (fn icollect [iter-tbl value-expr ...] + "Returns a sequential table made by running an iterator and evaluating an + expression that returns values to be inserted sequentially into the table. + This can be thought of as a \"list comprehension\". + + For example, + (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v))) + returns + [9 16 25]" + (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2)) + "expected iterator binding table") + (assert (not= nil value-expr) + "expected table value expression") + (assert (= nil ...) + "expected exactly one body expression. Wrap multiple expressions with do") + `(let [tbl# []] + (each ,iter-tbl + (tset tbl# (+ (length tbl#) 1) ,value-expr)) + tbl#)) + (fn partial [f ...] "Returns a function with all arguments partially applied to f." (let [body (list f ...)] @@ -2820,15 +3682,14 @@ do (if (table? a) (each [_ a (pairs a)] (check! a)) - (and (not (: (tostring a) :match "^?")) - (not= (tostring a) "&") - (not= (tostring a) "...")) + (let [as (tostring a)] + (and (not (as:match "^?")) (not= as "&") (not= as "_") (not= as "..."))) (table.insert args arity-check-position `(assert (not= nil ,a) - (: "Missing argument %s on %s:%s" - :format ,(tostring a) - ,(or a.filename "unknown") - ,(or a.line "?")))))) + (string.format "Missing argument %s on %s:%s" + ,(tostring a) + ,(or a.filename "unknown") + ,(or a.line "?")))))) (assert (= :table (type arglist)) "expected arg list") (each [_ a (ipairs arglist)] (check! a)) @@ -2840,14 +3701,13 @@ do "Define a single macro." (assert (sym? name) "expected symbol for macro name") (local args [...]) - `(macros { ,(tostring name) (fn ,name ,(unpack args))})) + `(macros { ,(tostring name) (fn ,(unpack args))})) (fn macrodebug [form return?] "Print the resulting form after performing macroexpansion. With a second argument, returns expanded form as a string instead of printing." - (let [(ok view) (pcall require :fennelview) - handle (if return? `do `print)] - `(,handle ,((if ok view tostring) (macroexpand form _SCOPE))))) + (let [handle (if return? `do `print)] + `(,handle ,(view (macroexpand form _SCOPE))))) (fn import-macros [binding1 module-name1 ...] "Binds a table of macros from each macro module according to a binding form. @@ -2858,31 +3718,63 @@ do (assert (and binding1 module-name1 (= 0 (% (select :# ...) 2))) "expected even number of binding/modulename pairs") (for [i 1 (select :# binding1 module-name1 ...) 2] - (local (binding modname) (select i binding1 module-name1 ...)) - ;; generate a subscope of current scope, use require-macros - ;; to bring in macro module. after that, we just copy the - ;; macros from subscope to scope. - (local scope (get-scope)) - (local subscope (fennel.scope scope)) - (fennel.compile-string (string.format "(require-macros %q)" - modname) - {:scope subscope}) - (if (sym? binding) - ;; bind whole table of macros to table bound to symbol - (do (tset scope.macros (. binding 1) {}) - (each [k v (pairs subscope.macros)] - (tset (. scope.macros (. binding 1)) k v))) + (let [(binding modname) (select i binding1 module-name1 ...) + ;; generate a subscope of current scope, use require-macros + ;; to bring in macro module. after that, we just copy the + ;; macros from subscope to scope. + scope (get-scope) + subscope (fennel.scope scope)] + (_SPECIALS.require-macros `(require-macros ,modname) subscope {} ast) + (if (sym? binding) + ;; bind whole table of macros to table bound to symbol + (do (tset scope.macros (. binding 1) {}) + (each [k v (pairs subscope.macros)] + (tset (. scope.macros (. binding 1)) k v))) - ;; 1-level table destructuring for importing individual macros - (table? binding) - (each [macro-name [import-key] (pairs binding)] - (assert (= :function (type (. subscope.macros macro-name))) - (.. "macro " macro-name " not found in module " modname)) - (tset scope.macros import-key (. subscope.macros macro-name))))) + ;; 1-level table destructuring for importing individual macros + (table? binding) + (each [macro-name [import-key] (pairs binding)] + (assert (= :function (type (. subscope.macros macro-name))) + (.. "macro " macro-name " not found in module " + (tostring modname))) + (tset scope.macros import-key (. subscope.macros macro-name)))))) nil) ;;; Pattern matching + (fn match-values [vals pattern unifications match-pattern] + (let [condition `(and) + bindings []] + (each [i pat (ipairs pattern)] + (let [(subcondition subbindings) (match-pattern [(. vals i)] pat + unifications)] + (table.insert condition subcondition) + (each [_ b (ipairs subbindings)] + (table.insert bindings b)))) + (values condition bindings))) + + (fn match-table [val pattern unifications match-pattern] + (let [condition `(and (= (type ,val) :table)) + bindings []] + (each [k pat (pairs pattern)] + (if (and (sym? pat) (= "&" (tostring pat))) + (do (assert (not (. pattern (+ k 2))) + "expected rest argument before last parameter") + (table.insert bindings (. pattern (+ k 1))) + (table.insert bindings [`(select ,k ((or table.unpack + _G.unpack) + ,val))])) + (and (= :number (type k)) + (= "&" (tostring (. pattern (- k 1))))) + nil ; don't process the pattern right after &; already got it + (let [subval `(. ,val ,k) + (subcondition subbindings) (match-pattern [subval] pat + unifications)] + (table.insert condition subcondition) + (each [_ b (ipairs subbindings)] + (table.insert bindings b))))) + (values condition bindings))) + (fn match-pattern [vals pattern unifications] "Takes the AST of values and a single pattern and returns a condition to determine if it matches as well as a list of bindings to @@ -2899,14 +3791,13 @@ do (in-scope? (. (multi-sym? pattern) 1)))) (values `(= ,val ,pattern) []) ;; unify a local we've seen already - (and (sym? pattern) - (. unifications (tostring pattern))) + (and (sym? pattern) (. unifications (tostring pattern))) (values `(= ,(. unifications (tostring pattern)) ,val) []) ;; bind a fresh local (sym? pattern) - (let [wildcard? (= (tostring pattern) "_")] + (let [wildcard? (: (tostring pattern) :find "^_")] (if (not wildcard?) (tset unifications (tostring pattern) val)) - (values (if (or wildcard? (: (tostring pattern) :find "^?")) + (values (if (or wildcard? (string.find (tostring pattern) "^?")) true `(not= ,(sym :nil) ,val)) [pattern val])) ;; guard clause @@ -2920,37 +3811,10 @@ do ;; multi-valued patterns (represented as lists) (list? pattern) - (let [condition `(and) - bindings []] - (each [i pat (ipairs pattern)] - (let [(subcondition subbindings) (match-pattern [(. vals i)] pat - unifications)] - (table.insert condition subcondition) - (each [_ b (ipairs subbindings)] - (table.insert bindings b)))) - (values condition bindings)) + (match-values vals pattern unifications match-pattern) ;; table patterns (= (type pattern) :table) - (let [condition `(and (= (type ,val) :table)) - bindings []] - (each [k pat (pairs pattern)] - (if (and (sym? pat) (= "&" (tostring pat))) - (do (assert (not (. pattern (+ k 2))) - "expected rest argument before last parameter") - (table.insert bindings (. pattern (+ k 1))) - (table.insert bindings [`(select ,k ((or _G.unpack - table.unpack) - ,val))])) - (and (= :number (type k)) - (= "&" (tostring (. pattern (- k 1))))) - nil ; don't process the pattern right after &; already got it - (let [subval `(. ,val ,k) - (subcondition subbindings) (match-pattern [subval] pat - unifications)] - (table.insert condition subcondition) - (each [_ b (ipairs subbindings)] - (table.insert bindings b))))) - (values condition bindings)) + (match-table val pattern unifications match-pattern) ;; literal value (values `(= ,val ,pattern) [])))) @@ -2988,6 +3852,7 @@ do {: -> : ->> : -?> : -?>> : doto : when : with-open + : collect : icollect : partial : lambda : pick-args : pick-values : macro : macrodebug : import-macros @@ -3000,7 +3865,13 @@ do end package.preload[module_name] = _0_ _ = nil - local env = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + local env = nil + do + local _1_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + _1_0["utils"] = utils + _1_0["fennel"] = mod + env = _1_0 + end local built_ins = eval(builtin_macros, {allowedGlobals = false, env = env, filename = "src/fennel/macros.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) for k, v in pairs(built_ins) do compiler.scopes.global.macros[k] = v diff --git a/lib/fennelview.lua b/lib/fennelview.lua deleted file mode 100644 index ecd5660..0000000 --- a/lib/fennelview.lua +++ /dev/null @@ -1,225 +0,0 @@ -local function view_quote(str) - return ("\"" .. str:gsub("\"", "\\\"") .. "\"") -end -local short_control_char_escapes = {["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "\\n"} -local long_control_char_escapes = nil -do - local long = {} - for i = 0, 31 do - local ch = string.char(i) - if not short_control_char_escapes[ch] then - short_control_char_escapes[ch] = ("\\" .. i) - long[ch] = ("\\%03d"):format(i) - end - end - long_control_char_escapes = long -end -local function escape(str) - return str:gsub("\\", "\\\\"):gsub("(%c)%f[0-9]", long_control_char_escapes):gsub("%c", short_control_char_escapes) -end -local function sequence_key_3f(k, len) - return ((type(k) == "number") and (1 <= k) and (k <= len) and (math.floor(k) == k)) -end -local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6} -local function sort_keys(a, b) - local ta = type(a) - local tb = type(b) - if ((ta == tb) and (ta ~= "boolean") and ((ta == "string") or (ta == "number"))) then - return (a < b) - else - local dta = type_order[a] - local dtb = type_order[b] - if (dta and dtb) then - return (dta < dtb) - elseif dta then - return true - elseif dtb then - return false - elseif "else" then - return (ta < tb) - end - end -end -local function get_sequence_length(t) - local len = 1 - for i in ipairs(t) do - len = i - end - return len -end -local function get_nonsequential_keys(t) - local keys = {} - local sequence_length = get_sequence_length(t) - for k in pairs(t) do - if not sequence_key_3f(k, sequence_length) then - table.insert(keys, k) - end - end - table.sort(keys, sort_keys) - return keys, sequence_length -end -local function count_table_appearances(t, appearances) - if (type(t) == "table") then - if not appearances[t] then - appearances[t] = 1 - for k, v in pairs(t) do - count_table_appearances(k, appearances) - count_table_appearances(v, appearances) - end - end - else - if (t and (t == t)) then - appearances[t] = ((appearances[t] or 0) + 1) - end - end - return appearances -end -local put_value = nil -local function puts(self, ...) - for _, v in ipairs({...}) do - table.insert(self.buffer, v) - end - return nil -end -local function tabify(self) - return puts(self, "\n", (self.indent):rep(self.level)) -end -local function already_visited_3f(self, v) - return (self.ids[v] ~= nil) -end -local function get_id(self, v) - local id = self.ids[v] - if not id then - local tv = type(v) - id = ((self["max-ids"][tv] or 0) + 1) - self["max-ids"][tv] = id - self.ids[v] = id - end - return tostring(id) -end -local function put_sequential_table(self, t, len) - puts(self, "[") - self.level = (self.level + 1) - for i = 1, len do - local _0_ = (1 + len) - if ((1 < i) and (i < _0_)) then - puts(self, " ") - end - put_value(self, t[i]) - end - self.level = (self.level - 1) - return puts(self, "]") -end -local function put_key(self, k) - if ((type(k) == "string") and k:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then - return puts(self, ":", k) - else - return put_value(self, k) - end -end -local function put_kv_table(self, t, ordered_keys) - puts(self, "{") - self.level = (self.level + 1) - for i, k in ipairs(ordered_keys) do - if (self["table-edges"] or (i ~= 1)) then - tabify(self) - end - put_key(self, k) - puts(self, " ") - put_value(self, t[k]) - end - for i, v in ipairs(t) do - tabify(self) - put_key(self, i) - puts(self, " ") - put_value(self, v) - end - self.level = (self.level - 1) - if self["table-edges"] then - tabify(self) - end - return puts(self, "}") -end -local function put_table(self, t) - local metamethod = nil - local function _1_() - local _0_0 = t - if _0_0 then - local _2_0 = getmetatable(_0_0) - if _2_0 then - return _2_0.__fennelview - else - return _2_0 - end - else - return _0_0 - end - end - metamethod = (self["metamethod?"] and _1_()) - if (already_visited_3f(self, t) and self["detect-cycles?"]) then - return puts(self, "#
") - elseif (self.level >= self.depth) then - return puts(self, "{...}") - elseif metamethod then - return puts(self, metamethod(t, self.fennelview)) - elseif "else" then - local non_seq_keys, len = get_nonsequential_keys(t) - local id = get_id(self, t) - if ((1 < (self.appearances[t] or 0)) and self["detect-cycles?"]) then - return puts(self, "#") - elseif ((#non_seq_keys == 0) and (#t == 0)) then - local function _2_() - if self["empty-as-square"] then - return "[]" - else - return "{}" - end - end - return puts(self, _2_()) - elseif (#non_seq_keys == 0) then - return put_sequential_table(self, t, len) - elseif "else" then - return put_kv_table(self, t, non_seq_keys) - end - end -end -local function _0_(self, v) - local tv = type(v) - if (tv == "string") then - return puts(self, view_quote(escape(v))) - elseif ((tv == "number") or (tv == "boolean") or (tv == "nil")) then - return puts(self, tostring(v)) - elseif (tv == "table") then - return put_table(self, v) - elseif "else" then - return puts(self, "#<", tostring(v), ">") - end -end -put_value = _0_ -local function one_line(str) - local ret = str:gsub("\n", " "):gsub("%[ ", "["):gsub(" %]", "]"):gsub("%{ ", "{"):gsub(" %}", "}"):gsub("%( ", "("):gsub(" %)", ")") - return ret -end -local function fennelview(x, options) - local options0 = (options or {}) - local inspector = nil - local function _1_(_241) - return fennelview(_241, options0) - end - local function _2_() - if options0["one-line"] then - return "" - else - return " " - end - end - inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["empty-as-square"] = options0["empty-as-square"], ["max-ids"] = {}, ["metamethod?"] = not (false == options0["metamethod?"]), ["table-edges"] = (options0["table-edges"] ~= false), appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _1_, ids = {}, indent = (options0.indent or _2_()), level = 0} - put_value(inspector, x) - local str = table.concat(inspector.buffer) - if options0["one-line"] then - return one_line(str) - else - return str - end -end -return fennelview diff --git a/main.lua b/main.lua index b58479b..f2a8305 100644 --- a/main.lua +++ b/main.lua @@ -1,7 +1,7 @@ -- bootstrap the compiler fennel = require("lib.fennel") table.insert(package.loaders, fennel.make_searcher({correlate=true})) -fv = require("lib.fennelview") +fv = fennel.view pp = function(x) print(fv(x)) end lume = require("lib.lume") -- these set global variables and can't be required after requiring core.strict @@ -16,4 +16,5 @@ function coroutine.resume(...) return state,result end +require("vendor.lite.main") require("wrap")