clone url: git://git.m455.casa/fa
esperbuild/espersrc/fennel-0.7.0/src/fennel/compiler.fnl
| 1 | ;; This is the core compiler module responsible for taking a parsed AST |
| 2 | ;; and turning it into Lua code. Main entry points are `compile` (which |
| 3 | ;; takes an AST), `compile-stream` and `compile-string`. |
| 4 | |
| 5 | (local utils (require "fennel.utils")) |
| 6 | (local parser (require "fennel.parser")) |
| 7 | (local friend (require :fennel.friend)) |
| 8 | |
| 9 | (local unpack (or _G.unpack table.unpack)) |
| 10 | |
| 11 | (local scopes []) |
| 12 | |
| 13 | (fn make-scope [parent] |
| 14 | "Create a new Scope, optionally under a parent scope. |
| 15 | Scopes are compile time constructs that are responsible for keeping track of |
| 16 | local variables, name mangling, and macros. They are accessible to user code |
| 17 | via the 'eval-compiler' special form (may change). They use metatables to |
| 18 | implement nesting. " |
| 19 | (let [parent (or parent scopes.global)] |
| 20 | {:includes (setmetatable [] {:__index (and parent parent.includes)}) |
| 21 | :macros (setmetatable [] {:__index (and parent parent.macros)}) |
| 22 | :manglings (setmetatable [] {:__index (and parent parent.manglings)}) |
| 23 | :refedglobals (setmetatable [] {:__index (and parent parent.refedglobals)}) |
| 24 | :specials (setmetatable [] {:__index (and parent parent.specials)}) |
| 25 | :symmeta (setmetatable [] {:__index (and parent parent.symmeta)}) |
| 26 | :unmanglings (setmetatable [] {:__index (and parent parent.unmanglings)}) |
| 27 | |
| 28 | :autogensyms [] |
| 29 | :vararg (and parent parent.vararg) |
| 30 | :depth (if parent (+ (or parent.depth 0) 1) 0) |
| 31 | :hashfn (and parent parent.hashfn) |
| 32 | :parent parent})) |
| 33 | |
| 34 | ;; If you add new calls to this function, please update fennel.friend |
| 35 | ;; as well to add suggestions for how to fix the new error! |
| 36 | (fn assert-compile [condition msg ast] |
| 37 | "Assert a condition and raise a compile error with line numbers. |
| 38 | The ast arg should be unmodified so that its first element is the form called." |
| 39 | (when (not condition) |
| 40 | (let [{: source : unfriendly} (or utils.root.options {})] |
| 41 | (utils.root.reset) |
| 42 | (if unfriendly |
| 43 | (let [m (getmetatable ast) |
| 44 | filename (or (and m m.filename) ast.filename "unknown") |
| 45 | line (or (and m m.line) ast.line "?") |
| 46 | target (tostring (if (utils.sym? (. ast 1)) |
| 47 | (utils.deref (. ast 1)) |
| 48 | (or (. ast 1) "()")))] |
| 49 | ;; if we use regular `assert' we can't set level to 0 |
| 50 | (error (string.format "Compile error in '%s' %s:%s: %s" |
| 51 | target filename line msg) 0)) |
| 52 | (friend.assert-compile condition msg ast source)))) |
| 53 | condition) |
| 54 | |
| 55 | (set scopes.global (make-scope)) |
| 56 | (set scopes.global.vararg true) |
| 57 | (set scopes.compiler (make-scope scopes.global)) |
| 58 | (set scopes.macro scopes.global) |
| 59 | |
| 60 | ;; Allow printing a string to Lua, also keep as 1 line. |
| 61 | (local serialize-subst {"\a" "\\a" "\b" "\\b" "\t" "\\t" |
| 62 | "\n" "n" "\v" "\\v" "\f" "\\f"}) |
| 63 | |
| 64 | (fn serialize-string [str] |
| 65 | (-> (string.format "%q" str) |
| 66 | (string.gsub "." serialize-subst) |
| 67 | (string.gsub "[€-ÿ]" #(.. "\\" ($:byte))))) |
| 68 | |
| 69 | (fn global-mangling [str] |
| 70 | "Mangler for global symbols. Does not protect against collisions, |
| 71 | but makes them unlikely. This is the mangling that is exposed to to the world." |
| 72 | (if (utils.valid-lua-identifier? str) |
| 73 | str |
| 74 | (.. "__fnl_global__" |
| 75 | (str:gsub "[^%w]" #(string.format "_%02x" ($:byte)))))) |
| 76 | |
| 77 | (fn global-unmangling [identifier] |
| 78 | "Reverse a global mangling. |
| 79 | Takes a Lua identifier and returns the Fennel symbol string that created it." |
| 80 | (match (string.match identifier "^__fnl_global__(.*)$") |
| 81 | rest (pick-values 1 (string.gsub rest "_[%da-f][%da-f]" |
| 82 | #(string.char (tonumber ($:sub 2) 16)))) |
| 83 | _ identifier)) |
| 84 | |
| 85 | (var allowed-globals nil) |
| 86 | |
| 87 | (fn global-allowed [name] |
| 88 | "If there's a provided list of allowed globals, don't let references thru that |
| 89 | aren't on the list. This list is set at the compiler entry points of compile |
| 90 | and compile-stream." |
| 91 | (or (not allowed-globals) (utils.member? name allowed-globals))) |
| 92 | |
| 93 | (fn unique-mangling [original mangling scope append] |
| 94 | (if (. scope.unmanglings mangling) |
| 95 | (unique-mangling original (.. original append) scope (+ append 1)) |
| 96 | mangling)) |
| 97 | |
| 98 | (fn local-mangling [str scope ast temp-manglings] |
| 99 | "Creates a symbol from a string by mangling it. ensures that the generated |
| 100 | symbol is unique if the input string is unique in the scope." |
| 101 | (assert-compile (not (utils.multi-sym? str)) |
| 102 | (.. "unexpected multi symbol " str) ast) |
| 103 | (let [;; Mapping mangling to a valid Lua identifier |
| 104 | raw (if (or (. utils.lua-keywords str) (str:match "^%d")) |
| 105 | (.. "_" str) |
| 106 | str) |
| 107 | mangling (-> raw |
| 108 | (string.gsub "-" "_") |
| 109 | (string.gsub "[^%w_]" #(string.format "_%02x" ($:byte)))) |
| 110 | unique (unique-mangling mangling mangling scope 0)] |
| 111 | (tset scope.unmanglings unique str) |
| 112 | (let [manglings (or temp-manglings scope.manglings)] |
| 113 | (tset manglings str unique)) |
| 114 | unique)) |
| 115 | |
| 116 | (fn apply-manglings [scope new-manglings ast] |
| 117 | "Calling this function will mean that further compilation in scope will use |
| 118 | these new manglings instead of the current manglings." |
| 119 | (each [raw mangled (pairs new-manglings)] |
| 120 | (assert-compile (not (. scope.refedglobals mangled)) |
| 121 | (.. "use of global " raw " is aliased by a local") ast) |
| 122 | (tset scope.manglings raw mangled))) |
| 123 | |
| 124 | (fn combine-parts [parts scope] |
| 125 | "Combine parts of a symbol." |
| 126 | (var ret (or (. scope.manglings (. parts 1)) (global-mangling (. parts 1)))) |
| 127 | (for [i 2 (# parts)] |
| 128 | (if (utils.valid-lua-identifier? (. parts i)) |
| 129 | (if (and parts.multi-sym-method-call (= i (# parts))) |
| 130 | (set ret (.. ret ":" (. parts i))) |
| 131 | (set ret (.. ret "." (. parts i)))) |
| 132 | (set ret (.. ret "[" (serialize-string (. parts i)) "]")))) |
| 133 | ret) |
| 134 | |
| 135 | (fn gensym [scope base] |
| 136 | "Generates a unique symbol in the scope." |
| 137 | (var (append mangling) (values 0 (.. (or base "") "_0_"))) |
| 138 | (while (. scope.unmanglings mangling) |
| 139 | (set mangling (.. (or base "") "_" append "_")) |
| 140 | (set append (+ append 1))) |
| 141 | (tset scope.unmanglings mangling (or base true)) |
| 142 | mangling) |
| 143 | |
| 144 | (fn autogensym [base scope] |
| 145 | "Generates a unique symbol in the scope based on the base name. Calling |
| 146 | repeatedly with the same base and same scope will return existing symbol |
| 147 | rather than generating new one." |
| 148 | (match (utils.multi-sym? base) |
| 149 | parts (do (tset parts 1 (autogensym (. parts 1) scope)) |
| 150 | (table.concat parts (or (and parts.multi-sym-method-call ":") "."))) |
| 151 | _ (or (. scope.autogensyms base) |
| 152 | (let [mangling (gensym scope (base:sub 1 (- 2)))] |
| 153 | (tset scope.autogensyms base mangling) |
| 154 | mangling)))) |
| 155 | |
| 156 | (fn check-binding-valid [symbol scope ast] |
| 157 | "Check to see if a symbol will be overshadowed by a special." |
| 158 | (let [name (utils.deref symbol)] |
| 159 | (assert-compile (not (or (. scope.specials name) (. scope.macros name))) |
| 160 | (: "local %s was overshadowed by a special form or macro" |
| 161 | :format name) ast) |
| 162 | (assert-compile (not (utils.quoted? symbol)) |
| 163 | (string.format "macro tried to bind %s without gensym" name) |
| 164 | symbol))) |
| 165 | |
| 166 | (fn declare-local [symbol meta scope ast temp-manglings] |
| 167 | "Declare a local symbol" |
| 168 | (check-binding-valid symbol scope ast) |
| 169 | (let [name (utils.deref symbol)] |
| 170 | (assert-compile (not (utils.multi-sym? name)) |
| 171 | (.. "unexpected multi symbol " name) ast) |
| 172 | (tset scope.symmeta name meta) |
| 173 | (local-mangling name scope ast temp-manglings))) |
| 174 | |
| 175 | (fn hashfn-arg-name [name multi-sym-parts scope] |
| 176 | (if (not scope.hashfn) nil |
| 177 | (= name "$") "$1" |
| 178 | multi-sym-parts |
| 179 | (do (when (and multi-sym-parts (= (. multi-sym-parts 1) "$")) |
| 180 | (tset multi-sym-parts 1 "$1")) |
| 181 | (table.concat multi-sym-parts ".")))) |
| 182 | |
| 183 | (fn symbol-to-expression [symbol scope reference?] |
| 184 | "Convert symbol to Lua code. Will only work for local symbols |
| 185 | if they have already been declared via declare-local" |
| 186 | (utils.hook :symbol-to-expression symbol scope reference?) |
| 187 | (let [name (. symbol 1) |
| 188 | multi-sym-parts (utils.multi-sym? name) |
| 189 | name (or (hashfn-arg-name name multi-sym-parts scope) name)] |
| 190 | (let [parts (or multi-sym-parts [name]) |
| 191 | etype (or (and (> (# parts) 1) "expression") "sym") |
| 192 | local? (. scope.manglings (. parts 1))] |
| 193 | (when (and local? (. scope.symmeta (. parts 1))) |
| 194 | (tset (. scope.symmeta (. parts 1)) "used" true)) |
| 195 | ;; if it's a reference and not a symbol which introduces a new binding |
| 196 | ;; then we need to check for allowed globals |
| 197 | (assert-compile (or (not reference?) local? (global-allowed (. parts 1))) |
| 198 | (.. "unknown global in strict mode: " (. parts 1)) symbol) |
| 199 | (when (and allowed-globals (not local?)) |
| 200 | (tset utils.root.scope.refedglobals (. parts 1) true)) |
| 201 | (utils.expr (combine-parts parts scope) etype)))) |
| 202 | |
| 203 | (fn emit [chunk out ast] |
| 204 | "Emit Lua code." |
| 205 | (if (= (type out) "table") |
| 206 | (table.insert chunk out) |
| 207 | (table.insert chunk {:ast ast :leaf out}))) |
| 208 | |
| 209 | (fn peephole [chunk] |
| 210 | "Do some peephole optimization." |
| 211 | (if chunk.leaf chunk |
| 212 | (and (>= (# chunk) 3) |
| 213 | (= (. (. chunk (- (# chunk) 2)) "leaf") "do") |
| 214 | (not (. (. chunk (- (# chunk) 1)) "leaf")) |
| 215 | (= (. (. chunk (# chunk)) "leaf") "end")) |
| 216 | (let [kid (peephole (. chunk (- (# chunk) 1))) |
| 217 | new-chunk {:ast chunk.ast}] |
| 218 | (for [i 1 (- (# chunk) 3)] |
| 219 | (table.insert new-chunk (peephole (. chunk i)))) |
| 220 | (for [i 1 (# kid)] |
| 221 | (table.insert new-chunk (. kid i))) |
| 222 | new-chunk) |
| 223 | (utils.map chunk peephole))) |
| 224 | |
| 225 | (fn flatten-chunk-correlated [main-chunk] |
| 226 | "Correlate line numbers in input with line numbers in output." |
| 227 | (fn flatten [chunk out last-line file] |
| 228 | (var last-line last-line) |
| 229 | (if chunk.leaf |
| 230 | (tset out last-line (.. (or (. out last-line) "") " " chunk.leaf)) |
| 231 | (each [_ subchunk (ipairs chunk)] |
| 232 | (when (or subchunk.leaf (> (# subchunk) 0)) ; ignore empty chunks |
| 233 | ;; don't increase line unless it's from the same file |
| 234 | (when (and subchunk.ast (= file subchunk.ast.file)) |
| 235 | (set last-line (math.max last-line (or subchunk.ast.line 0)))) |
| 236 | (set last-line (flatten subchunk out last-line file))))) |
| 237 | last-line) |
| 238 | (let [out [] |
| 239 | last (flatten main-chunk out 1 main-chunk.file)] |
| 240 | (for [i 1 last] |
| 241 | (when (= (. out i) nil) |
| 242 | (tset out i ""))) |
| 243 | (table.concat out "\n"))) |
| 244 | |
| 245 | (fn flatten-chunk [sm chunk tab depth] |
| 246 | "Flatten a tree of indented Lua source code lines. |
| 247 | Tab is what is used to indent a block." |
| 248 | (if chunk.leaf |
| 249 | (let [code chunk.leaf |
| 250 | info chunk.ast] |
| 251 | (when sm |
| 252 | (table.insert sm (or (and info info.line) (- 1)))) |
| 253 | code) |
| 254 | (let [tab (match tab |
| 255 | true " " false "" tab tab nil "")] |
| 256 | (fn parter [c] |
| 257 | (when (or c.leaf (> (# c) 0)) |
| 258 | (let [sub (flatten-chunk sm c tab (+ depth 1))] |
| 259 | (if (> depth 0) |
| 260 | (.. tab (sub:gsub "\n" (.. "\n" tab))) |
| 261 | sub)))) |
| 262 | (table.concat (utils.map chunk parter) "\n")))) |
| 263 | |
| 264 | ;; Some global state for all fennel sourcemaps. For the time being, this seems |
| 265 | ;; the easiest way to store the source maps. Sourcemaps are stored with source |
| 266 | ;; being mapped as the key, prepended with '@' if it is a filename (like |
| 267 | ;; debug.getinfo returns for source). The value is an array of mappings for |
| 268 | ;; each line. |
| 269 | (local fennel-sourcemap []) |
| 270 | |
| 271 | (fn make-short-src [source] |
| 272 | (let [source (source:gsub "\n" " ")] |
| 273 | (if (<= (# source) 49) |
| 274 | (.. "[fennel \"" source "\"]") |
| 275 | (.. "[fennel \"" (source:sub 1 46) "...\"]")))) |
| 276 | |
| 277 | (fn flatten [chunk options] |
| 278 | "Return Lua source and source map table." |
| 279 | (let [chunk (peephole chunk)] |
| 280 | (if options.correlate |
| 281 | (values (flatten-chunk-correlated chunk) []) |
| 282 | (let [sm [] |
| 283 | ret (flatten-chunk sm chunk options.indent 0)] |
| 284 | (when sm |
| 285 | (set sm.short_src (make-short-src (or options.filename |
| 286 | options.source ret))) |
| 287 | (set sm.key (if options.filename (.. "@" options.filename) ret)) |
| 288 | (tset fennel-sourcemap sm.key sm)) |
| 289 | (values ret sm))))) |
| 290 | |
| 291 | (fn make-metadata [] |
| 292 | "Make module-wide state table for metadata." |
| 293 | (setmetatable |
| 294 | [] {:__index {:get (fn [self tgt key] |
| 295 | (when (. self tgt) |
| 296 | (. (. self tgt) key))) |
| 297 | :set (fn [self tgt key value] |
| 298 | (tset self tgt (or (. self tgt) [])) |
| 299 | (tset (. self tgt) key value) |
| 300 | tgt) |
| 301 | :setall (fn [self tgt ...] |
| 302 | (let [kv-len (select "#" ...) |
| 303 | kvs [...]] |
| 304 | (when (not= (% kv-len 2) 0) |
| 305 | (error "metadata:setall() expected even number of k/v pairs")) |
| 306 | (tset self tgt (or (. self tgt) [])) |
| 307 | (for [i 1 kv-len 2] |
| 308 | (tset (. self tgt) (. kvs i) (. kvs (+ i 1)))) |
| 309 | tgt))} |
| 310 | :__mode "k"})) |
| 311 | |
| 312 | (fn exprs1 [exprs] |
| 313 | "Convert expressions to Lua string." |
| 314 | (table.concat (utils.map exprs 1) ", ")) |
| 315 | |
| 316 | (fn keep-side-effects [exprs chunk start ast] |
| 317 | "Compile side effects for a chunk." |
| 318 | (let [start (or start 1)] |
| 319 | (for [j start (# exprs)] |
| 320 | (let [se (. exprs j)] |
| 321 | ;; Avoid the rogue 'nil' expression (nil is usually a literal, |
| 322 | ;; but becomes an expression if a special form returns 'nil') |
| 323 | (if (and (= se.type "expression") (not= (. se 1) "nil")) |
| 324 | (emit chunk (string.format "do local _ = %s end" (tostring se)) ast) |
| 325 | (= se.type "statement") |
| 326 | (let [code (tostring se)] |
| 327 | (emit chunk (or (and (= (code:byte) 40) |
| 328 | (.. "do end " code)) code) ast))))))) |
| 329 | |
| 330 | (fn handle-compile-opts [exprs parent opts ast] |
| 331 | "Does some common handling of returns and register targets for special |
| 332 | forms. Also ensures a list expression has an acceptable number of expressions |
| 333 | if opts contains the nval option." |
| 334 | (when opts.nval |
| 335 | (let [n opts.nval |
| 336 | len (# exprs)] |
| 337 | (when (not= n len) |
| 338 | (if (> len n) |
| 339 | (do ; drop extra |
| 340 | (keep-side-effects exprs parent (+ n 1) ast) |
| 341 | (for [i (+ n 1) len] |
| 342 | (tset exprs i nil))) |
| 343 | (for [i (+ (# exprs) 1) n] ; pad with nils |
| 344 | (tset exprs i (utils.expr :nil :literal))))))) |
| 345 | (when opts.tail |
| 346 | (emit parent (string.format "return %s" (exprs1 exprs)) ast)) |
| 347 | (when opts.target |
| 348 | (let [result (exprs1 exprs)] |
| 349 | (emit parent (string.format "%s = %s" opts.target |
| 350 | (if (= result "") "nil" result)) ast))) |
| 351 | (if (or opts.tail opts.target) |
| 352 | ;; Prevent statements and expression from being used twice if they |
| 353 | ;; have side-effects. Since if the target or tail options are set, |
| 354 | ;; the expressions are already emitted, we should not return them. This |
| 355 | ;; is fine, as when these options are set, the caller doesn't need the |
| 356 | ;; result anyways. |
| 357 | {:returned true} |
| 358 | (doto exprs (tset :returned true)))) |
| 359 | |
| 360 | (fn find-macro [ast scope multi-sym-parts] |
| 361 | (fn find-in-table [t i] |
| 362 | (if (<= i (# multi-sym-parts)) |
| 363 | (find-in-table (and (utils.table? t) (. t (. multi-sym-parts i))) |
| 364 | (+ i 1)) |
| 365 | t)) |
| 366 | (let [macro* (and (utils.sym? (. ast 1)) |
| 367 | (. scope.macros (utils.deref (. ast 1))))] |
| 368 | (if (and (not macro*) multi-sym-parts) |
| 369 | (let [nested-macro (find-in-table scope.macros 1)] |
| 370 | (assert-compile (or (not (. scope.macros (. multi-sym-parts 1))) |
| 371 | (= (type nested-macro) :function)) |
| 372 | "macro not found in imported macro module" ast) |
| 373 | nested-macro) |
| 374 | macro*))) |
| 375 | |
| 376 | (fn macroexpand* [ast scope once] |
| 377 | "Expand macros in the ast. Only do one level if once is true." |
| 378 | (if (not (utils.list? ast)) ; bail early if not a list |
| 379 | ast |
| 380 | (let [macro* (find-macro ast scope (utils.multi-sym? (. ast 1)))] |
| 381 | (if (not macro*) |
| 382 | ast |
| 383 | (let [old-scope scopes.macro |
| 384 | _ (set scopes.macro scope) |
| 385 | (ok transformed) (pcall macro* (unpack ast 2))] |
| 386 | (set scopes.macro old-scope) |
| 387 | (assert-compile ok transformed ast) |
| 388 | (if (or once (not transformed)) |
| 389 | transformed |
| 390 | (macroexpand* transformed scope))))))) |
| 391 | |
| 392 | (fn compile-special [ast scope parent opts special] |
| 393 | (let [exprs (or (special ast scope parent opts) |
| 394 | (utils.expr :nil :literal)) |
| 395 | ;; Be very accepting of strings or expressions as well as lists |
| 396 | ;; or expressions |
| 397 | exprs (if (= (type exprs) :string) |
| 398 | (utils.expr exprs :expression) |
| 399 | exprs) |
| 400 | exprs (if (utils.expr? exprs) |
| 401 | [exprs] |
| 402 | exprs)] |
| 403 | ;; Unless the special form explicitly handles the target, tail, |
| 404 | ;; and nval properties, (indicated via the 'returned' flag), |
| 405 | ;; handle these options. |
| 406 | (if (not exprs.returned) |
| 407 | (handle-compile-opts exprs parent opts ast) |
| 408 | (or opts.tail opts.target) |
| 409 | {:returned true} |
| 410 | exprs))) |
| 411 | |
| 412 | ;; TODO: too long |
| 413 | (fn compile-call [ast scope parent opts compile1] |
| 414 | (utils.hook :call ast scope) |
| 415 | (let [len (# ast) |
| 416 | first (. ast 1) |
| 417 | multi-sym-parts (utils.multi-sym? first) |
| 418 | special (and (utils.sym? first) (. scope.specials (utils.deref first)))] |
| 419 | (assert-compile (> len 0) |
| 420 | "expected a function, macro, or special to call" ast) |
| 421 | (if special |
| 422 | (compile-special ast scope parent opts special) |
| 423 | (and multi-sym-parts multi-sym-parts.multi-sym-method-call) |
| 424 | (let [table-with-method (table.concat |
| 425 | [(unpack multi-sym-parts 1 |
| 426 | (- (# multi-sym-parts) 1))] |
| 427 | ".") |
| 428 | method-to-call (. multi-sym-parts (# multi-sym-parts)) |
| 429 | new-ast (utils.list (utils.sym ":" scope) |
| 430 | (utils.sym table-with-method scope) |
| 431 | method-to-call (select 2 (unpack ast)))] |
| 432 | (compile1 new-ast scope parent opts)) |
| 433 | (let [fargs [] ; regular function call |
| 434 | fcallee (. (compile1 (. ast 1) scope parent {:nval 1}) 1)] |
| 435 | (assert-compile (not= fcallee.type :literal) |
| 436 | (.. "cannot call literal value " (tostring first)) ast) |
| 437 | (for [i 2 len] |
| 438 | (let [subexprs (compile1 (. ast i) scope parent |
| 439 | {:nval (or (and (not= i len) 1) nil)})] |
| 440 | (table.insert fargs (or (. subexprs 1) (utils.expr :nil :literal))) |
| 441 | (if (= i len) |
| 442 | ;; Add sub expressions to function args |
| 443 | (for [j 2 (# subexprs)] |
| 444 | (table.insert fargs (. subexprs j))) |
| 445 | ;; Emit sub expression only for side effects |
| 446 | (keep-side-effects subexprs parent 2 (. ast i))))) |
| 447 | (let [call (string.format "%s(%s)" (tostring fcallee) (exprs1 fargs))] |
| 448 | (handle-compile-opts [(utils.expr call :statement)] parent opts ast)))))) |
| 449 | |
| 450 | (fn compile-varg [ast scope parent opts] |
| 451 | (assert-compile scope.vararg "unexpected vararg" ast) |
| 452 | (handle-compile-opts [(utils.expr "..." "varg")] parent opts ast)) |
| 453 | |
| 454 | (fn compile-sym [ast scope parent opts] |
| 455 | (let [multi-sym-parts (utils.multi-sym? ast)] |
| 456 | (assert-compile (not (and multi-sym-parts multi-sym-parts.multi-sym-method-call)) |
| 457 | "multisym method calls may only be in call position" ast) |
| 458 | ;; Handle nil as special symbol - it resolves to the nil literal |
| 459 | ;; rather than being unmangled. Alternatively, we could remove it |
| 460 | ;; from the lua keywords table. |
| 461 | (let [e (if (= (. ast 1) "nil") |
| 462 | (utils.expr "nil" "literal") |
| 463 | (symbol-to-expression ast scope true))] |
| 464 | (handle-compile-opts [e] parent opts ast)))) |
| 465 | |
| 466 | (fn compile-scalar [ast _scope parent opts] |
| 467 | (let [serialize (match (type ast) |
| 468 | :nil tostring |
| 469 | :boolean tostring |
| 470 | :string serialize-string |
| 471 | :number (partial string.format "%.17g"))] |
| 472 | (handle-compile-opts [(utils.expr (serialize ast) :literal)] parent opts))) |
| 473 | |
| 474 | (fn compile-table [ast scope parent opts compile1] |
| 475 | (let [buffer []] |
| 476 | (for [i 1 (# ast)] ; write numeric keyed values |
| 477 | (let [nval (and (not= i (# ast)) 1)] |
| 478 | (table.insert buffer (exprs1 (compile1 (. ast i) scope parent |
| 479 | {:nval nval}))))) |
| 480 | (fn write-other-values [k] |
| 481 | (when (or (not= (type k) :number) |
| 482 | (not= (math.floor k) k) |
| 483 | (< k 1) (> k (# ast))) |
| 484 | (if (and (= (type k) :string) (utils.valid-lua-identifier? k)) |
| 485 | [k k] |
| 486 | (let [[compiled] (compile1 k scope parent {:nval 1}) |
| 487 | kstr (.. "[" (tostring compiled) "]")] |
| 488 | [kstr k])))) |
| 489 | (let [keys (doto (utils.kvmap ast write-other-values) |
| 490 | (table.sort (fn [a b] (< (. a 1) (. b 1)))))] |
| 491 | (utils.map keys (fn [k] |
| 492 | (let [v (tostring (. (compile1 (. ast (. k 2)) |
| 493 | scope parent |
| 494 | {:nval 1}) 1))] |
| 495 | (string.format "%s = %s" (. k 1) v))) |
| 496 | buffer)) |
| 497 | (handle-compile-opts [(utils.expr (.. "{" (table.concat buffer ", ") "}") |
| 498 | :expression)] parent opts ast))) |
| 499 | |
| 500 | (fn compile1 [ast scope parent opts] |
| 501 | "Compile an AST expression in the scope into parent, a tree of lines that is |
| 502 | eventually compiled into Lua code. Also returns some information about the |
| 503 | evaluation of the compiled expression, which can be used by the calling |
| 504 | function. Macros are resolved here, as well as special forms in that order. |
| 505 | |
| 506 | * the `ast` param is the root AST to compile |
| 507 | * the `scope` param is the scope in which we are compiling |
| 508 | * the `parent` param is the table of lines that we are compiling into. |
| 509 | add lines to parent by appending strings. Add indented blocks by appending |
| 510 | tables of more lines. |
| 511 | * the `opts` param contains info about where the form is being compiled |
| 512 | |
| 513 | Fields of `opts` include: |
| 514 | target: mangled name of symbol(s) being compiled to. |
| 515 | Could be one variable, 'a', or a list, like 'a, b, _0_'. |
| 516 | tail: boolean indicating tail position if set. If set, form will generate |
| 517 | a return instruction. |
| 518 | nval: The number of values to compile to if it is known to be a fixed value. |
| 519 | |
| 520 | In Lua, an expression can evaluate to 0 or more values via multiple returns. In |
| 521 | many cases, Lua will drop extra values and convert a 0 value expression to |
| 522 | nil. In other cases, Lua will use all of the values in an expression, such as |
| 523 | in the last argument of a function call. Nval is an option passed to compile1 |
| 524 | to say that the resulting expression should have at least n values. It lets us |
| 525 | generate better code, because if we know we are only going to use 1 or 2 values |
| 526 | from an expression, we can create 1 or 2 locals to store intermediate results |
| 527 | rather than turn the expression into a closure that is called immediately, |
| 528 | which we have to do if we don't know." |
| 529 | (let [opts (or opts []) |
| 530 | ast (macroexpand* ast scope)] |
| 531 | (if (utils.list? ast) |
| 532 | (compile-call ast scope parent opts compile1) |
| 533 | (utils.varg? ast) |
| 534 | (compile-varg ast scope parent opts) |
| 535 | (utils.sym? ast) |
| 536 | (compile-sym ast scope parent opts) |
| 537 | (= (type ast) "table") |
| 538 | (compile-table ast scope parent opts compile1) |
| 539 | (or (= (type ast) "nil") (= (type ast) "boolean") |
| 540 | (= (type ast) "number") (= (type ast) "string")) |
| 541 | (compile-scalar ast scope parent opts) |
| 542 | (assert-compile false (.. "could not compile value of type " |
| 543 | (type ast)) ast)))) |
| 544 | |
| 545 | ;; You may be tempted to clean up and refactor this function because it's so |
| 546 | ;; huge and stateful but it really needs to get replaced; it is too tightly |
| 547 | ;; coupled to the way the compiler outputs Lua; it should be split into general |
| 548 | ;; data-driven parts vs Lua-emitting parts. |
| 549 | (fn destructure [to from ast scope parent opts] |
| 550 | "Implements destructuring for forms like let, bindings, etc. |
| 551 | Takes a number of opts to control behavior. |
| 552 | * var: Whether or not to mark symbols as mutable |
| 553 | * declaration: begin each assignment with 'local' in output |
| 554 | * nomulti: disallow multisyms in the destructuring. for (local) and (global) |
| 555 | * noundef: Don't set undefined bindings. (set) |
| 556 | * forceglobal: Don't allow local bindings" |
| 557 | (let [opts (or opts {}) |
| 558 | {: isvar : declaration : nomulti : noundef : forceglobal : forceset} opts |
| 559 | setter (if declaration "local %s = %s" "%s = %s") |
| 560 | new-manglings []] |
| 561 | |
| 562 | (fn getname [symbol up1] |
| 563 | "Get Lua source for symbol, and check for errors" |
| 564 | (let [raw (. symbol 1)] |
| 565 | (assert-compile (not (and nomulti (utils.multi-sym? raw))) |
| 566 | (.. "unexpected multi symbol " raw) up1) |
| 567 | (if declaration |
| 568 | ;; Technically this is too early to declare the local, but leaving |
| 569 | ;; out the meta table and setting it later works around the problem. |
| 570 | (declare-local symbol nil scope symbol new-manglings) |
| 571 | (let [parts (or (utils.multi-sym? raw) [raw]) |
| 572 | meta (. scope.symmeta (. parts 1))] |
| 573 | (when (and (= (# parts) 1) (not forceset)) |
| 574 | (assert-compile (not (and forceglobal meta)) |
| 575 | (string.format "global %s conflicts with local" |
| 576 | (tostring symbol)) symbol) |
| 577 | (assert-compile (not (and meta (not meta.var))) |
| 578 | (.. "expected var " raw) symbol) |
| 579 | (assert-compile (or meta (not noundef)) |
| 580 | (.. "expected local " (. parts 1)) symbol)) |
| 581 | (when forceglobal |
| 582 | (assert-compile (not (. scope.symmeta (. scope.unmanglings raw))) |
| 583 | (.. "global " raw " conflicts with local") symbol) |
| 584 | (tset scope.manglings raw (global-mangling raw)) |
| 585 | (tset scope.unmanglings (global-mangling raw) raw) |
| 586 | (when allowed-globals |
| 587 | (table.insert allowed-globals raw))) |
| 588 | (. (symbol-to-expression symbol scope) 1))))) |
| 589 | |
| 590 | (fn compile-top-target [lvalues] |
| 591 | "Compile the outer most form. We can generate better Lua in this case." |
| 592 | ;; Calculate initial rvalue |
| 593 | (let [inits (utils.map lvalues #(if (. scope.manglings $) $ "nil")) |
| 594 | init (table.concat inits ", ") |
| 595 | lvalue (table.concat lvalues ", ")] |
| 596 | (var (plen plast) (values (# parent) (. parent (# parent)))) |
| 597 | (local ret (compile1 from scope parent {:target lvalue})) |
| 598 | (when declaration |
| 599 | ;; A single leaf emitted at the end of the parent chunk means a |
| 600 | ;; simple assignment a = x was emitted, and we can just splice |
| 601 | ;; "local " onto the front of it. However, we can't just check |
| 602 | ;; based on plen, because some forms (such as include) insert new |
| 603 | ;; chunks at the top of the parent chunk rather than just at the |
| 604 | ;; end; this loop checks for this occurance and updates plen to be |
| 605 | ;; the index of the last thing in the parent before compiling the |
| 606 | ;; new value. |
| 607 | (for [pi plen (# parent)] |
| 608 | (when (= (. parent pi) plast) |
| 609 | (set plen pi))) |
| 610 | (if (and (= (# parent) (+ plen 1)) (. (. parent (# parent)) "leaf")) |
| 611 | (tset (. parent (# parent)) :leaf |
| 612 | (.. "local " (. (. parent (# parent)) "leaf"))) |
| 613 | (table.insert parent (+ plen 1) |
| 614 | {:ast ast :leaf (.. "local " lvalue " = " init)}))) |
| 615 | ret)) |
| 616 | |
| 617 | (fn effective-key [key val] |
| 618 | (let [key (if (and (utils.sym? key) (= (tostring key) ":") (utils.sym? val)) |
| 619 | (tostring val) |
| 620 | key)] |
| 621 | (if (= (type key) :string) |
| 622 | (serialize-string key) |
| 623 | key))) |
| 624 | |
| 625 | (fn destructure1 [left rightexprs up1 top] |
| 626 | "Recursive auxiliary function" |
| 627 | (if (and (utils.sym? left) (not= (. left 1) "nil")) |
| 628 | (let [lname (getname left up1)] |
| 629 | (check-binding-valid left scope left) |
| 630 | (if top |
| 631 | (compile-top-target [lname]) |
| 632 | (emit parent (setter:format lname (exprs1 rightexprs)) left)) |
| 633 | ;; We have to declare meta for the left *after* compiling the right |
| 634 | ;; see https://todo.sr.ht/~technomancy/fennel/12 |
| 635 | (when declaration |
| 636 | (tset scope.symmeta (utils.deref left) {:var isvar}))) |
| 637 | (utils.table? left) ; table destructuring |
| 638 | (let [s (gensym scope)] |
| 639 | (var right (if top |
| 640 | (exprs1 (compile1 from scope parent)) |
| 641 | (exprs1 rightexprs))) |
| 642 | (when (= right "") |
| 643 | (set right "nil")) |
| 644 | (emit parent (string.format "local %s = %s" s right) left) |
| 645 | (each [k v (utils.stablepairs left)] |
| 646 | (if (and (utils.sym? (. left k)) (= (. (. left k) 1) "&")) |
| 647 | (do |
| 648 | (assert-compile (and (= (type k) "number") |
| 649 | (not (. left (+ k 2)))) |
| 650 | "expected rest argument before last parameter" |
| 651 | left) |
| 652 | (let [unpack-str "{(table.unpack or unpack)(%s, %s)}" |
| 653 | formatted (string.format unpack-str s k) |
| 654 | subexpr (utils.expr formatted "expression")] |
| 655 | (destructure1 (. left (+ k 1)) [subexpr] left) |
| 656 | (lua "return"))) |
| 657 | (let [subexpr (utils.expr (string.format "%s[%s]" s |
| 658 | (effective-key k v)) |
| 659 | :expression)] |
| 660 | (destructure1 v [subexpr] left))))) |
| 661 | (utils.list? left) ;; values destructuring |
| 662 | (let [(left-names tables) (values [] [])] |
| 663 | (each [i name (ipairs left)] |
| 664 | (if (utils.sym? name) ; binding directly to a name |
| 665 | (table.insert left-names (getname name up1)) |
| 666 | (let [symname (gensym scope)] |
| 667 | ;; further destructuring of tables inside values |
| 668 | (table.insert left-names symname) |
| 669 | (tset tables i [name (utils.expr symname "sym")])))) |
| 670 | (if top |
| 671 | (compile-top-target left-names) |
| 672 | (let [lvalue (table.concat left-names ", ") |
| 673 | setting (setter:format lvalue (exprs1 rightexprs))] |
| 674 | (emit parent setting left))) |
| 675 | (when declaration |
| 676 | (each [_ sym (ipairs left)] |
| 677 | (tset scope.symmeta (utils.deref sym) {:var isvar}))) |
| 678 | ;; recurse if left-side tables found |
| 679 | (each [_ pair (utils.stablepairs tables)] |
| 680 | (destructure1 (. pair 1) [(. pair 2)] left))) |
| 681 | (assert-compile false (string.format "unable to bind %s %s" |
| 682 | (type left) (tostring left)) |
| 683 | (or (and (= (type (. up1 2)) "table") (. up1 2)) up1))) |
| 684 | (when top |
| 685 | {:returned true})) |
| 686 | |
| 687 | (let [ret (destructure1 to nil ast true)] |
| 688 | (utils.hook :destructure from to scope) |
| 689 | (apply-manglings scope new-manglings ast) |
| 690 | ret))) |
| 691 | |
| 692 | (fn require-include [ast scope parent opts] |
| 693 | (fn opts.fallback [e] |
| 694 | (utils.expr (string.format "require(%s)" (tostring e)) :statement)) |
| 695 | (scopes.global.specials.include ast scope parent opts)) |
| 696 | |
| 697 | (fn compile-stream [strm options] |
| 698 | (let [opts (utils.copy options) |
| 699 | old-globals allowed-globals |
| 700 | scope (or opts.scope (make-scope scopes.global)) |
| 701 | vals [] |
| 702 | chunk []] |
| 703 | (utils.root:set-reset) |
| 704 | (set allowed-globals opts.allowedGlobals) |
| 705 | (when (= opts.indent nil) |
| 706 | (set opts.indent " ")) |
| 707 | (when opts.requireAsInclude |
| 708 | (set scope.specials.require require-include)) |
| 709 | (set (utils.root.chunk utils.root.scope utils.root.options) |
| 710 | (values chunk scope opts)) |
| 711 | (each [_ val (parser.parser strm opts.filename opts)] |
| 712 | (table.insert vals val)) |
| 713 | (for [i 1 (# vals)] |
| 714 | (let [exprs (compile1 (. vals i) scope chunk |
| 715 | {:nval (or (and (< i (# vals)) 0) nil) |
| 716 | :tail (= i (# vals))})] |
| 717 | (keep-side-effects exprs chunk nil (. vals i)))) |
| 718 | (set allowed-globals old-globals) |
| 719 | (utils.root.reset) |
| 720 | (flatten chunk opts))) |
| 721 | |
| 722 | (fn compile-string [str opts] |
| 723 | (compile-stream (parser.string-stream str) (or opts {}))) |
| 724 | |
| 725 | (fn compile [ast opts] |
| 726 | (let [opts (utils.copy opts) |
| 727 | old-globals allowed-globals |
| 728 | chunk [] |
| 729 | scope (or opts.scope (make-scope scopes.global))] |
| 730 | (utils.root:set-reset) |
| 731 | (set allowed-globals opts.allowedGlobals) |
| 732 | (when (= opts.indent nil) |
| 733 | (set opts.indent " ")) |
| 734 | (when opts.requireAsInclude |
| 735 | (set scope.specials.require require-include)) |
| 736 | (set (utils.root.chunk utils.root.scope utils.root.options) |
| 737 | (values chunk scope opts)) |
| 738 | (let [exprs (compile1 ast scope chunk {:tail true})] |
| 739 | (keep-side-effects exprs chunk nil ast) |
| 740 | (set allowed-globals old-globals) |
| 741 | (utils.root.reset) |
| 742 | (flatten chunk opts)))) |
| 743 | |
| 744 | (fn traceback-frame [info] |
| 745 | (if (and (= info.what "C") info.name) |
| 746 | (string.format " [C]: in function '%s'" info.name) |
| 747 | (= info.what "C") |
| 748 | " [C]: in ?" |
| 749 | (let [remap (. fennel-sourcemap info.source)] |
| 750 | (when (and remap (. remap info.currentline)) |
| 751 | ;; And some global info |
| 752 | (set info.short-src remap.short-src) |
| 753 | ;; Overwrite info with values from the mapping |
| 754 | ;; (mapping is now just integer, but may |
| 755 | ;; eventually be a table) |
| 756 | (set info.currentline (. remap info.currentline))) |
| 757 | (if (= info.what "Lua") |
| 758 | (string.format " %s:%d: in function %s" |
| 759 | info.short_src info.currentline |
| 760 | (if info.name (.. "'" info.name "'") "?")) |
| 761 | (= info.short-src "(tail call)") |
| 762 | " (tail call)" |
| 763 | (string.format " %s:%d: in main chunk" |
| 764 | info.short_src info.currentline))))) |
| 765 | |
| 766 | (fn traceback [msg start] |
| 767 | "A custom traceback function for Fennel that looks similar to debug.traceback. |
| 768 | Use with xpcall to produce fennel specific stacktraces. Skips frames from the |
| 769 | compiler by default; these can be re-enabled with export FENNEL_DEBUG=trace." |
| 770 | (let [msg (or msg "")] |
| 771 | (if (and (or (msg:find "^Compile error") (msg:find "^Parse error")) |
| 772 | (not (utils.debug-on? :trace))) |
| 773 | msg ; skip the trace because it's compiler internals. |
| 774 | (let [lines []] |
| 775 | (if (or (msg:find "^Compile error") (msg:find "^Parse error")) |
| 776 | (table.insert lines msg) |
| 777 | (let [newmsg (msg:gsub "^[^:]*:%d+:%s+" "runtime error: ")] |
| 778 | (table.insert lines newmsg))) |
| 779 | (table.insert lines "stack traceback:") |
| 780 | (var (done? level) (values false (or start 2))) |
| 781 | ;; This would be cleaner factored out into its own recursive |
| 782 | ;; function, but that would interfere with the traceback itself! |
| 783 | (while (not done?) |
| 784 | (match (debug.getinfo level "Sln") |
| 785 | nil (set done? true) |
| 786 | info (table.insert lines (traceback-frame info))) |
| 787 | (set level (+ level 1))) |
| 788 | (table.concat lines "\n"))))) |
| 789 | |
| 790 | (fn entry-transform [fk fv] |
| 791 | "Make a transformer for key / value table pairs, preserving all numeric keys" |
| 792 | (fn [k v] (if (= (type k) "number") |
| 793 | (values k (fv v)) |
| 794 | (values (fk k) (fv v))))) |
| 795 | |
| 796 | (fn no [] "Consume everything and return nothing." nil) |
| 797 | |
| 798 | (fn mixed-concat [t joiner] |
| 799 | (let [seen []] |
| 800 | (var (ret s) (values "" "")) |
| 801 | (each [k v (ipairs t)] |
| 802 | (table.insert seen k) |
| 803 | (set ret (.. ret s v)) |
| 804 | (set s joiner)) |
| 805 | (each [k v (utils.stablepairs t)] |
| 806 | (when (not (. seen k)) |
| 807 | (set ret (.. ret s "[" k "]" "=" v)) |
| 808 | (set s joiner))) |
| 809 | ret)) |
| 810 | |
| 811 | ;; TODO: too long |
| 812 | (fn do-quote [form scope parent runtime?] |
| 813 | "Expand a quoted form into a data literal, evaluating unquote" |
| 814 | (fn q [x] (do-quote x scope parent runtime?)) |
| 815 | (if (utils.varg? form) |
| 816 | (do |
| 817 | (assert-compile (not runtime?) |
| 818 | "quoted ... may only be used at compile time" form) |
| 819 | "_VARARG") |
| 820 | (utils.sym? form) ; symbol |
| 821 | (let [filename (if form.filename (string.format "%q" form.filename) :nil) |
| 822 | symstr (utils.deref form)] |
| 823 | (assert-compile (not runtime?) |
| 824 | "symbols may only be used at compile time" form) |
| 825 | ;; We should be able to use "%q" for this but Lua 5.1 throws an error |
| 826 | ;; when you try to format nil, because it's extremely bad. |
| 827 | (if (or (symstr:find "#$") (symstr:find "#[:.]")) ; autogensym |
| 828 | (string.format "sym('%s', nil, {filename=%s, line=%s})" |
| 829 | (autogensym symstr scope) filename (or form.line :nil)) |
| 830 | ;; prevent non-gensymed symbols from being bound as an identifier |
| 831 | (string.format "sym('%s', nil, {quoted=true, filename=%s, line=%s})" |
| 832 | symstr filename (or form.line :nil)))) |
| 833 | (and (utils.list? form) ; unquote |
| 834 | (utils.sym? (. form 1)) |
| 835 | (= (utils.deref (. form 1)) :unquote)) |
| 836 | (let [payload (. form 2) |
| 837 | res (unpack (compile1 payload scope parent))] |
| 838 | (. res 1)) |
| 839 | (utils.list? form) ; list |
| 840 | (let [mapped (utils.kvmap form (entry-transform no q)) |
| 841 | filename (if form.filename (string.format "%q" form.filename) :nil)] |
| 842 | (assert-compile (not runtime?) |
| 843 | "lists may only be used at compile time" form) |
| 844 | ;; Constructing a list and then adding file/line data to it triggers a |
| 845 | ;; bug where it changes the value of # for lists that contain nils in |
| 846 | ;; them; constructing the list all in one go with the source data and |
| 847 | ;; contents is how we construct lists in the parser and works around |
| 848 | ;; this problem; allowing # to work in a way that lets us see the nils. |
| 849 | (string.format (.. "setmetatable({filename=%s, line=%s, bytestart=%s, %s}" |
| 850 | ", getmetatable(list()))") |
| 851 | filename (or form.line :nil) (or form.bytestart :nil) |
| 852 | (mixed-concat mapped ", "))) |
| 853 | (= (type form) "table") ; table |
| 854 | (let [mapped (utils.kvmap form (entry-transform q q)) |
| 855 | source (getmetatable form) |
| 856 | filename (if source.filename (string.format "%q" source.filename) :nil)] |
| 857 | (string.format "setmetatable({%s}, {filename=%s, line=%s})" |
| 858 | (mixed-concat mapped ", ") filename |
| 859 | (if source source.line :nil))) |
| 860 | (= (type form) "string") |
| 861 | (serialize-string form) |
| 862 | (tostring form))) |
| 863 | |
| 864 | {;; compiling functions |
| 865 | : compile : compile1 : compile-stream : compile-string : emit : destructure |
| 866 | : require-include |
| 867 | |
| 868 | ;; AST functions |
| 869 | : autogensym : gensym : do-quote : global-mangling : global-unmangling |
| 870 | : apply-manglings :macroexpand macroexpand* |
| 871 | |
| 872 | ;; scope functions |
| 873 | : declare-local : make-scope : keep-side-effects : symbol-to-expression |
| 874 | |
| 875 | ;; general |
| 876 | :assert assert-compile : scopes : traceback :metadata (make-metadata) |
| 877 | } |