1314 lines
50 KiB
Scheme
1314 lines
50 KiB
Scheme
;;; Rebirth Lisp implemented in Birth Lisp (self-hosting)
|
||
;;;
|
||
;;; Copyright (C) 2017 Mike Gerwitz
|
||
;;;
|
||
;;; This file is part of Gibble.
|
||
;;;
|
||
;;; Gibble is free software: you can redistribute it and/or modify
|
||
;;; it under the terms of the GNU Affero General Public License as
|
||
;;; published by the Free Software Foundation, either version 3 of the
|
||
;;; License, or (at your option) any later version.
|
||
;;;
|
||
;;; This program is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU Affero General Public License
|
||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
;;;
|
||
;;; THIS IS TEMPORARY CODE that will be REWRITTEN IN GIBBLE LISP ITSELF after
|
||
;;; a very basic bootstrap is complete. It is retained as an important
|
||
;;; artifact for those who wish to build Gibble from scratch without using
|
||
;;; another version of Gibble itself. This is called "self-hosting".
|
||
;;;
|
||
;;; This is the compiler for Rebirth Lisp---it builds off of Birth by
|
||
;;; first eliminating the need for libprebirth; this allows _all_
|
||
;;; development to happen in a Lisp dialect, which liberates the last
|
||
;;; remaining process that isn't technically self-hosted. So, Rebirth
|
||
;;; completes the raw, self-hosting bootstrapping process.
|
||
;;;
|
||
;;; To continue with the creepy birthing puns, you can consider libprebirth
|
||
;; to be the umbilical cord. After Birth, it's still attached---here we
|
||
;;; cut it.
|
||
;;;
|
||
;;; Of course, bootstrapping can't end there: we need a fully functioning
|
||
;;; Scheme compiler. Rebirth may as well be called Rerebirth, or
|
||
;;; Rererebirth, or Re*birth, or Reⁿbirth---it is a recursively self-hosting
|
||
;;; compiler. It adds features to itself each time it compiles itself.
|
||
;;;
|
||
;;; Note that we're dealing with a small subset of Scheme here, so certain
|
||
;;; things might be done differently given a proper implementation.
|
||
;;;
|
||
;;; This is an exact copy of `birth.scm', modified to introduce additional
|
||
;;; features. This is important, since Birth is a 1:1 translation of the
|
||
;;; Prebirth compiler and needs to stay that way. This fork allows us to
|
||
;;; vary as much as we want from the initial implementation. See the commit
|
||
;;; history for this file for more information as to how it evolved (the
|
||
;;; first commit is the direct copy before actual code changes).
|
||
;;;
|
||
;;; This file follows a narrative (from Birth to Reⁿbirth), but it's more of
|
||
;;; a choose-your-adventure-book-style narrative: order of certain
|
||
;;; definitions unfortunately matters in this simple implementation. For
|
||
;;; example, primitive macros (e.g. `if') must be defined before they are
|
||
;;; used, so those appear at the top of this file, despite their definitions
|
||
;;; not being supported until future passes.
|
||
;;;
|
||
;;; So, to begin, go to `==STEP 0=='.
|
||
|
||
|
||
;; ==Step 2== (don't start here; see Step 0 below)
|
||
;;
|
||
;; Did you read the other steps first? If not, you're out of order; skip
|
||
;; down to Step 0 first and then come back here.
|
||
;;
|
||
;; Back? Good!
|
||
;;
|
||
;; Now that we have macro support, we can start to refactor parts of the
|
||
;; compiler into macros---rather than maintaining features as part of the
|
||
;; compiler itself, we maintain them as a library used alongside the
|
||
;; program. This also has another important benefit: additional compiler
|
||
;; features resulting from these definitions do not require another Rebirth
|
||
;; compilation pass (that is, Re⁽ⁿ⁺¹⁾birth) before they are available to
|
||
;; use.
|
||
;;
|
||
;; To make sure that these macros are not thwarted by the existing `fnmap'
|
||
;; definitions, `fnmap' has been refactored to remove the respective
|
||
;; definitions using `cond-expand'; see `fnmap-premacro'.
|
||
;;
|
||
;; These are by no means meant to be solid implementations; strong
|
||
;; deficiencies exist, and don't expect this to work properly in every
|
||
;; case. They will be replaced with proper R7RS implementations in the
|
||
;; future.
|
||
;;
|
||
;; Initially, everything here was a near-exact copy of the `fnmap-premacro'
|
||
;; forms, re-arranged as needed for compilation (see limitations of
|
||
;; `cdfn-macro'), so all changes are clearly visible in the repository
|
||
;; history.
|
||
(cond-expand
|
||
(cdfn-macro
|
||
(define-macro (%es:native-apply fn . args)
|
||
(`quote
|
||
(string->es
|
||
(unquote (string-append
|
||
(token-value fn)
|
||
"(" (join "," (map sexp->es args)) ")")))))
|
||
|
||
(define-macro (es:console . args)
|
||
(`quote (%es:native-apply console.log (unquote@ args))))
|
||
(define-macro (es:error . args)
|
||
(`quote (%es:native-apply console.error (unquote@ args))))
|
||
|
||
(define-macro (es:raw . body)
|
||
(`quote
|
||
(string->es (unquote@ body))))
|
||
|
||
(define-macro (define-es-macro decl . body)
|
||
(quasiquote
|
||
(define-macro (unquote decl)
|
||
(list
|
||
(quote string->es)
|
||
(string-append (unquote@ body))))))
|
||
|
||
;; Don't worry---basic tail call support (at least for recursion) is
|
||
;; nearing, and then we can get rid of this ugly thing.
|
||
(define-es-macro (es:while pred . body)
|
||
"(function(__whilebrk){"
|
||
"while (" (sexp->es pred) "){\n"
|
||
(body->es body #f) " if (__whilebrk) break;\n"
|
||
"}\n"
|
||
"})(false)")
|
||
(define-es-macro (es:break)
|
||
"__whilebrk=true")
|
||
|
||
(define-es-macro (lambda fnargs . body)
|
||
"function(" (join ", " (map sexp->es fnargs)) "){\n"
|
||
(body->es body #t)
|
||
"}")
|
||
|
||
(define-es-macro (let* bindings . body)
|
||
"(function(){\n"
|
||
(join "" (map (lambda (binding)
|
||
(string-append
|
||
" let " (sexp->es (car binding))
|
||
" = " (sexp->es (cadr binding)) ";\n"))
|
||
bindings))
|
||
(body->es body #t) "\n"
|
||
" })()")
|
||
|
||
(define-es-macro (let bindings . body)
|
||
(let* ((fparams (join ", " (map sexp->es
|
||
(map car bindings))))
|
||
(fargs (join ", " (map sexp->es
|
||
(map cadr bindings)))))
|
||
(string-append "(function(" fparams "){\n"
|
||
(body->es body #t) "\n"
|
||
"})(" fargs ")")))
|
||
|
||
(define-es-macro (and . args)
|
||
"(function(__and){\n"
|
||
(join "" (map (lambda (expr)
|
||
(string-append
|
||
"__and = " (sexp->es expr) "; "
|
||
"if (!_truep(__and)) return false;\n"))
|
||
args))
|
||
"return __and;})()")
|
||
|
||
(define-es-macro (or . args)
|
||
"(function(__or){\n"
|
||
(join "" (map (lambda (expr)
|
||
(string-append
|
||
"__or = " (sexp->es expr) "; "
|
||
"if (_truep(__or)) return __or;\n"))
|
||
args))
|
||
"return false;})()")
|
||
|
||
(define-es-macro (if pred t . rest)
|
||
(let ((f (and (pair? rest)
|
||
(car rest))))
|
||
(string-append
|
||
"(function(){"
|
||
"if (_truep(" (sexp->es pred) ")){return " (sexp->es t) ";}"
|
||
(or (and (pair? f)
|
||
(string-append "else{return " (sexp->es f) ";}"))
|
||
"")
|
||
"})()")))
|
||
|
||
(define-es-macro (case key . clauses)
|
||
"(function(){const _key=" (sexp->es key) ";\n"
|
||
"switch (_key){\n"
|
||
(join ""
|
||
(map (lambda (data exprs)
|
||
(string-append
|
||
(if (and (token? data)
|
||
(string=? "else" (token-lexeme data)))
|
||
"default:\n"
|
||
(join ""
|
||
(map (lambda (datum)
|
||
(string-append
|
||
"case " (sexp->es datum) ":\n"))
|
||
data)))
|
||
(body->es exprs #t) "\n"))
|
||
(map car clauses)
|
||
(map cdr clauses)))
|
||
"}})()")
|
||
|
||
(define-es-macro (set! varid val)
|
||
(sexp->es varid) " = " (sexp->es val))))
|
||
|
||
|
||
|
||
;; ==STEP 0== (start here)
|
||
;;
|
||
;; The first step in the Rebirth process is to liberate ourselves from
|
||
;; libprebirth.
|
||
;;
|
||
;; Here we define the libprebirth primitives. When we first compile
|
||
;; Rebirth with Birth, `string->es' is not yet available, because it is
|
||
;; only implemented in Rebirth. Further, Birth includes libprebirth in
|
||
;; its output, so we cannot blindly redefine the procedures without
|
||
;; producing an error.
|
||
;;
|
||
;; Once Rebirth is compiled with Birth, Rebirth can then compile
|
||
;; itself. Since Rebirth _does_ implement `string->es', and further _does
|
||
;; not_ include libprebirth in its output, we can define the libprebirth
|
||
;; primitives ourselves in Rebirth Lisp. Cut the cord.
|
||
;;
|
||
;; Some of these definitions aren't valid: variable arguments, for
|
||
;; example, aren't represented _at all_---the `define' form will be
|
||
;; properly implemented in the future to correct this.
|
||
(cond-expand
|
||
(string->es
|
||
(define #t (string->es "true"))
|
||
(define #f (string->es "false"))
|
||
|
||
;; _truep is used only internally and is still defined as a JS function
|
||
;; for brevity
|
||
(string->es "const _truep = x => x !== false")
|
||
|
||
;; intended for whether a procedure is defined, mostly
|
||
(define (es:defined? x)
|
||
(let ((id (tname->id x)))
|
||
(string->es "eval('typeof ' + $$id) !== 'undefined'")))
|
||
|
||
(define (es:typeof x)
|
||
(string->es "typeof $$x"))
|
||
|
||
(define (symbol=? x y)
|
||
(and (string=? (es:typeof x) "symbol")
|
||
(eq? x y)))
|
||
|
||
(define (es:arg->arr args)
|
||
(string->es "Array.prototype.slice.call($$args)"))
|
||
(define (list . xs) xs)
|
||
|
||
;; warning: only compares two values
|
||
(define (= x y)
|
||
(string->es "+$$x === +$$y"))
|
||
(define (> x y)
|
||
(string->es "+$$y > +$$x"))
|
||
(define (< x y)
|
||
(string->es "+$$y < +$$x"))
|
||
|
||
;; warning: doesn't verify that it's a pair
|
||
(define (length xs)
|
||
(string->es "$$xs.length"))
|
||
|
||
(define (es:array? xs)
|
||
(string->es "Array.isArray($$xs)"))
|
||
|
||
(define (es:-assert-list xs)
|
||
(or (es:array? xs)
|
||
(error "expecting list")))
|
||
|
||
(define (es:-assert-pair xs)
|
||
(es:-assert-list xs)
|
||
(if (= 0 (length xs))
|
||
(error "expecting pair")
|
||
#t))
|
||
|
||
;; ignore obj for now
|
||
(define (error msg obj)
|
||
(string->es "throw Error($$msg)")
|
||
#f) ; prevent above from being in tail position and prefixing "return"
|
||
|
||
;; warning: these only operate on arrays
|
||
(define (cons obj1 obj2)
|
||
(es:-assert-list obj2)
|
||
(string->es "[$$obj1].concat($$obj2)"))
|
||
(define (car pair)
|
||
(es:-assert-pair pair)
|
||
(string->es "$$pair[0]"))
|
||
(define (cdr pair)
|
||
(es:-assert-pair pair)
|
||
(string->es "$$pair.slice(1)"))
|
||
|
||
(define (append . args)
|
||
(fold (lambda (x xs)
|
||
(es:-assert-list x)
|
||
(string->es "$$xs.concat($$x)"))
|
||
(list)
|
||
args))
|
||
|
||
;; warning: these two are wholly inadequate
|
||
(define (list? xs)
|
||
(string->es "Array.isArray($$xs)"))
|
||
(define (pair? xs)
|
||
(and (list? xs)
|
||
(> 0 (length xs))))
|
||
|
||
;; R7RS string
|
||
(define (substring s start end)
|
||
(string->es "$$s.substring($$start, $$end)"))
|
||
(define (string-length s)
|
||
(string->es "$$s.length"))
|
||
(define (string=? s1 s2)
|
||
(string->es "typeof $$s1 === 'string' && $$s1 === $$s2"))
|
||
(define (string-ref s i)
|
||
(string->es "$$s[$$i] || $$error(`value out of range: ${$$i}`)"))
|
||
(define (string-append . xs)
|
||
(string->es "$$xs.join('')"))
|
||
|
||
(define (eq? x y)
|
||
(string->es "$$x === $$y"))
|
||
|
||
;; R7RS math
|
||
(define (+ . xs)
|
||
(fold (lambda (y x)
|
||
(string->es "$$x + $$y"))
|
||
0
|
||
xs))
|
||
(define (- . xs)
|
||
(fold (lambda (y x)
|
||
(string->es "$$x - $$y"))
|
||
(car xs)
|
||
(cdr xs)))
|
||
(define (zero? x)
|
||
(eq? x 0))
|
||
|
||
;; SRFI-1
|
||
;; warning: fold here only supports one list
|
||
(define (fold f init xs)
|
||
(string->es "$$xs.reduce((prev, x) => $$f(x, prev), $$init)"))
|
||
|
||
;; warning: map here uses the length of the first list, not the shortest
|
||
(define (map f . xs)
|
||
(string->es
|
||
"$$xs[0].map((_, i) => $$f.apply(null, $$xs.map(x => x[i])))"))
|
||
|
||
(define (es:regexp s opts)
|
||
(string->es "new RegExp($$s, $$opts)"))
|
||
(define (es:match r s)
|
||
(string->es "$$s.match($$r) || false"))
|
||
(define (es:replace r repl s)
|
||
(string->es "$$s.replace($$r, $$repl)"))
|
||
|
||
(define *fsdata*
|
||
(if (string->es "typeof __fsinit === 'undefined'")
|
||
(string->es "{}")
|
||
(string->es "__fsinit")))
|
||
|
||
(define *fs*
|
||
(if (string->es "typeof require === 'undefined'")
|
||
(string->es
|
||
"{
|
||
readFileSync(path)
|
||
{
|
||
throw Error(`Cannot load ${path} (no fs module)`);
|
||
},
|
||
}")
|
||
(string->es "require('fs')")))
|
||
|
||
;; so that we do not have to modify existing compiler output (which would
|
||
;; break the first round of compilation before these are defined)
|
||
(string->es "const fsdata = $$$k$fsdata$k$")
|
||
(string->es "const fs = $$$k$fs$k$")
|
||
|
||
(define (es:file->string path)
|
||
(if (string->es "fsdata[$$path] === undefined")
|
||
(string->es
|
||
"fsdata[$$path] = fs.readFileSync($$path).toString()")
|
||
(string->es "fsdata[$$path]")))))
|
||
|
||
|
||
;; ==STEP 1== (see Step 0 above)
|
||
;;
|
||
;; Without macro support, anything that involves producing code with
|
||
;; variable structure at compile-time must be hard-coded in the
|
||
;; compiler. Perhaps the greatest power in Lisp is the ability to extend
|
||
;; the language through its own facilities---its ability to parse itself
|
||
;; and treat itself as data.
|
||
;;
|
||
;; So we need to introduce macro support.
|
||
;;
|
||
;; This is not a trivial task: RⁿRS has a rich and powerful system that
|
||
;; would be quite a bit of work upfront to implement. Instead, we're
|
||
;; going to focus on traditional Lisp macros, which are conceptually
|
||
;; rather simple---they produce a list that, when expanded, is treated as
|
||
;; Lisp code as if the user had typed it herself.
|
||
;;
|
||
;; Macros hold the full power of Lisp---macro expansion _is_
|
||
;; compilation. This means that we need to compile macro expansions as
|
||
;; their own separate programs during the normal compilation process and
|
||
;; splice in the result. But to execute the macro, we need to execute
|
||
;; ECMAScript code that we just generated. In other words: the evil eval.
|
||
;;
|
||
;; ECMAScript has two ways of evaluating ES code contained in a string:
|
||
;; through the `eval' function and by instantiating `Function' with a
|
||
;; string argument representing the body of the function (or something
|
||
;; that can be cast into a string). Good thing, otherwise we'd find
|
||
;; ourselves painfully writing a Lisp interpreter in Rebirth Lisp.
|
||
;;
|
||
;; This implementation is very simple---there's very little code but a great
|
||
;; deal of comments. They describe important caveats and hopefully
|
||
;; enlighten the curious reader.
|
||
(cond-expand
|
||
(string->es
|
||
;; Stores macros for compiler runtime.
|
||
(string->es "const _macros = {}")
|
||
|
||
(define (cdfn-macro sexp)
|
||
(define (%make-macro-proc sexp)
|
||
;; The syntax for a macro definition is the same as a procedure
|
||
;; definition. In fact, that's exactly what we want, since a macro is
|
||
;; a procedure that, when applied, produces a list. But we want an
|
||
;; anonymous function, so override the id to the empty string.
|
||
(let* ((proc-es (cdfn-proc sexp "")))
|
||
;; Rather than outputting the generated ES function, we're going to
|
||
;; immediately evaluate it. This is a trivial task, but how we do
|
||
;; it is important: we need to maintain lexical scoping. This
|
||
;; means that we must use `eval'---`new Function' does not create a
|
||
;; closure.
|
||
;;
|
||
;; The only thing we need to do to ensure that eval returns a
|
||
;; function is to enclose the function definition in
|
||
;; parenthesis. This results in something along the lines of:
|
||
;; eval("(function(args){...})")
|
||
;;
|
||
;; If you're confused by the execution environment (compiler
|
||
;; runtime vs. compiler output), don't worry, you're not
|
||
;; alone. We're actually dealing with a number of things here:
|
||
;;
|
||
;; 1. Use `string->es' below to produce _compiler output_ for the
|
||
;; next version of a Rebirth Lisp compiler that will be
|
||
;; responsible for actually running the `eval'.
|
||
;; 2. That next version of the compiler will then compile
|
||
;; ECMAScript function definition from macro procedure source
|
||
;; using `cdfn-proc' as above.
|
||
;; 3. This will then be run by the compiler _at runtime_ by
|
||
;; running the `eval' statement below (which is part of the
|
||
;; program just as if it were Lisp).
|
||
;; 4. The result will be the procedure `proc-es' available to the
|
||
;; compiler at runtime rather than produced as compiler output.
|
||
;;
|
||
;; There's a lot of words here for so little code! We currently
|
||
;; lack the language features necessary to produce the types of
|
||
;; abstractions that would make this dissertation unnecessary.
|
||
(string->es "eval('(' + $$proc$_$es + ')')")))
|
||
|
||
;; We then store the macro by name in memory in `_macros'. When
|
||
;; invoked, it will apply the result of the above generated procedure
|
||
;; to `macro-compile-result' (defined below), which will produce the
|
||
;; ECMAScript code resulting from the macro application.
|
||
;;
|
||
;; There are consequences to this naive implementation. Rebirth is a
|
||
;; dumb transpiler that relies on features of ECMAScript to do its
|
||
;; job. In particular, we don't have any dependency graph or lexical
|
||
;; scoping or any of those necessary features---we let ECMAScript take
|
||
;; care of all of that. That means that we have no idea what is
|
||
;; defined or even what has been compiled; we just transpile and move
|
||
;; on blindly. Any errors resulting from undefined procedures, for
|
||
;; example, occur at runtime in the compiled output.
|
||
;;
|
||
;; These are features that will be implemented in Gibble Lisp; that's
|
||
;; not something to distract ourselves with now.
|
||
;;
|
||
;; So there are some corollaries:
|
||
;;
|
||
;; 1. Macros must be defined _before_ they are called. Order
|
||
;; matters.
|
||
;; 2. Macros can only make use of what is defined in the compiler
|
||
;; runtime environment---if a procedure is defined, it won't be
|
||
;; available to macros until the next compilation pass. This is
|
||
;; because we have no dependency graph and cannot automatically
|
||
;; eval dependencies so that they are available in the execution
|
||
;; context.
|
||
;; - To work around that, procedures can be defined within the
|
||
;; macro body. Of course, then they're encapsulated within it,
|
||
;; which is not always desirable.
|
||
;;
|
||
;; While this implementation is crippled, it does still provide good
|
||
;; foundation with which we can move forward. Our use of recursive
|
||
;; Reⁿbirth passes and `cond-expand' makes this less of an issue as
|
||
;; well, since we're recursing anyway.
|
||
(let ((macro-proc (%make-macro-proc sexp))
|
||
(macro-id (token-value (caadr sexp)))) ; XXX
|
||
(string->es
|
||
"_macros[$$macro$_$id] = function(){
|
||
return $$macro$_$compile$_$result(
|
||
$$macro$_$proc.apply(this,arguments))};")
|
||
;; Because the macro procedure was evaluated at runtime, it would
|
||
;; never actually itself be output. This makes debugging difficult,
|
||
;; so we'll output it as a comment. This is admittedly a little bit
|
||
;; dangerous, as we're assuming that no block comments will ever
|
||
;; appear in `macro-proc'. But at the time of writing, this
|
||
;; assumption is perfectly valid.
|
||
(string-append "/*macro " macro-id ": " macro-proc "*/")))
|
||
|
||
|
||
;; Compile the S-expression resulting from the macro application into
|
||
;; ECMAScript.
|
||
;;
|
||
;; This simply converts the given S-expression SEXP into an AST and
|
||
;; compiles it using the same procedures that we've been using for all
|
||
;; other code. See below for details.
|
||
(define (macro-compile-result sexp)
|
||
(sexp->es (list->ast sexp)))
|
||
|
||
|
||
;; Produce a Rebirth List AST from an internal list form.
|
||
;;
|
||
;; Up until this point, the only way to represent Rebirth Lisp was using
|
||
;; a typical Lisp form. With macros, however, we have bypassed that
|
||
;; source form---we're working with our own internal representation of a
|
||
;; list.
|
||
;;
|
||
;; The structure of the AST is already done---it mirrors that of the list
|
||
;; itself. What we need to do is map over the list, recursively, and
|
||
;; convert each item into a token.
|
||
;;
|
||
;; Consider the tokens processed by `toks->ast': comments,
|
||
;; opening/closing delimiters, strings, and symbols. We don't need to
|
||
;; worry about comments since we aren't dealing with source code. We
|
||
;; also don't need to worry about opening/closing delimiters since we
|
||
;; already have our list. This leaves only two token types to worry
|
||
;; about: strings and symbols.
|
||
;;
|
||
;; And then there's the fascinating case of macro arguments. When a
|
||
;; macro or procedure application are encountered during compilation, the
|
||
;; arguments are represented as tokens (see `apply-proc-or-macro'). As
|
||
;; just mentioned, the end goal is to convert our list SEXP into tokens
|
||
;; for the AST. But the arguments are _already_ tokens, so they need no
|
||
;; additional processing---we just splice them in as-is! This trivial
|
||
;; operation yields the powerful Lisp macro ability we're looking for:
|
||
;; the ability to pass around chunks of the AST.
|
||
;;
|
||
;; Consequently, we have Rebirth-specific syntax to deal with when
|
||
;; processing the AST within macros. Up until this point, in place of
|
||
;; macros, we have used `fnmap', which operates on tokens. That is the
|
||
;; case here as well: if a macro wishes to assert on or manipulate any
|
||
;; syntax it is given, it must use the Rebirth token API that the rest of
|
||
;; the system uses. For example, say we have a macro `foo' that asserts
|
||
;; on its first argument as a string:
|
||
;;
|
||
;; (foo "moo") => "cow"
|
||
;; (foo "bar") => "baz"
|
||
;;
|
||
;; This will _not_ work:
|
||
;;
|
||
;; (define-macro (foo x)
|
||
;; (if (string=? x "moo") "cow" "baz"))
|
||
;;
|
||
;; The reason is that `x' is not a string---it is a `token?'. Instead,
|
||
;; we must do this:
|
||
;;
|
||
;; (define-macro (foo x)
|
||
;; (if (string=? (token-value x) "moo") "cow" "baz"))
|
||
;;
|
||
;; Of course, if you do not need to make that determination at
|
||
;; compile-time, you can defer it to runtime instead and use `string=?':
|
||
;;
|
||
;; (define-macro (foo x)
|
||
;; (quasiquote (if (string=? (unquote x) "moo") "cow" "baz")))
|
||
;;
|
||
;; Simple implementation, complex consequences. Scheme uses syntax
|
||
;; objects; we'll provide that abstraction over our implementation at
|
||
;; some point.
|
||
;;
|
||
;; Okay! That's trivial enough, isn't it?
|
||
(define (list->ast sexp)
|
||
;; Anything that is not a string is considered to be a symbol
|
||
;; token. But note that a symbol token does not necessarily mean an
|
||
;; ECMAScript Symbol object.
|
||
(define (%list-item item)
|
||
(case (es:typeof item)
|
||
(("string")
|
||
(list "string" item))
|
||
(("symbol")
|
||
(list "symbol" (string->es "Symbol.keyFor($$item)")))
|
||
(else
|
||
(list "symbol" (string->es "''+$$item")))))
|
||
|
||
;; Recursively create tokens for each item. Note that we will not have
|
||
;; any useful source code or source location information---just use the
|
||
;; empty string and 0 for them, respectively.
|
||
;;
|
||
;; The lexeme will simply be the item converted into a string, whatever
|
||
;; that happens to be.
|
||
(if (token? sexp)
|
||
sexp
|
||
(if (list? sexp)
|
||
(map list->ast sexp)
|
||
(let* ((item-parts (%list-item sexp))
|
||
(type (car item-parts))
|
||
(lexeme (cadr item-parts)))
|
||
(car (make-token type lexeme "" 0))))))))
|
||
|
||
;; (go to Step 2 above)
|
||
|
||
|
||
;; pair selection
|
||
(define (cadr xs)
|
||
(car (cdr xs)))
|
||
(define (caadr xs)
|
||
(car (car (cdr xs))))
|
||
(define (caddr xs)
|
||
(car (cdr (cdr xs))))
|
||
(define (cadddr xs)
|
||
(car (cdr (cdr (cdr xs)))))
|
||
(define (caddddr xs)
|
||
(car (cdr (cdr (cdr (cdr xs))))))
|
||
(define (cddr xs)
|
||
(cdr (cdr xs)))
|
||
|
||
(define (not x)
|
||
(if x #f #t))
|
||
|
||
;; for convenience
|
||
(define (es:match-regexp re s)
|
||
(es:match (es:regexp re) s))
|
||
|
||
|
||
|
||
;; Convert source input into a string of tokens.
|
||
;;
|
||
;; This is the lexer. Whitespace is ignored. The grammar consists of
|
||
;; simple s-expressions.
|
||
;;
|
||
;; Tokens are produced with `make-token'. The source SRC will be
|
||
;; left-truncated as input is processed. POS exists for producing metadata
|
||
;; for error reporting---it has no impact on parsing.
|
||
;;
|
||
;; This implementation was originally recursive and immutable, but the stack
|
||
;; was being exhausted, so it was refactored into an inferior
|
||
;; implementation. Note the use of `es:while' and `es:break'---these are
|
||
;; quick fixes to the problem of stack exhaustion in browsers (where we have
|
||
;; no control over the stack limit); proper tail call support will come
|
||
;; later when we have a decent architecture in place.
|
||
;;
|
||
;; The result is a list of tokens. See `token' for the format.
|
||
(define (lex src pos)
|
||
(let ((toks (list)))
|
||
(es:while #t ; browser stack workaround
|
||
(let* ((ws (or (es:match-regexp "^\\s+"
|
||
src)
|
||
(list "")))
|
||
(ws-len (string-length (car ws)))
|
||
(trim (substring src ws-len)) ; ignore whitespace, if any
|
||
(newpos (+ pos ws-len))) ; adj pos to account for removed ws
|
||
|
||
(if (string=? "" trim)
|
||
(es:break) ; EOF and we're done
|
||
|
||
;; normally we'd use `string-ref' here, but then we'd have to
|
||
;; implement Scheme characters, so let's keep this simple and keep
|
||
;; with strings
|
||
(let* ((ch (substring trim 0 1))
|
||
(t (case ch
|
||
;; comments extend until the end of the line
|
||
((";") (let ((eol (es:match-regexp "^(.*?)(\\n|$)" trim)))
|
||
(make-token "comment" (cadr eol) trim newpos)))
|
||
|
||
;; left and right parenthesis are handled in the same
|
||
;; manner: they produce distinct tokens with
|
||
;; single-character lexemes
|
||
(("(") (make-token "open" ch trim newpos))
|
||
((")") (make-token "close" ch trim newpos))
|
||
|
||
;; strings are delimited by opening and closing ASCII
|
||
;; double quotes, which can be escaped with a
|
||
;; backslash
|
||
(("\"") (let ((str (es:match-regexp
|
||
"^\"(|(?:.|\\\n)*?[^\\\\])\""
|
||
trim)))
|
||
(or str (parse-error
|
||
src pos
|
||
"missing closing string delimiter"))
|
||
;; a string token consists of the entire
|
||
;; string including quotes as its lexeme,
|
||
;; but its value will be the value of the
|
||
;; string without quotes due to the `str'
|
||
;; match group (see `token')
|
||
(make-token "string" str trim newpos)))
|
||
|
||
(else
|
||
;; anything else is considered a symbol up until
|
||
;; whitespace or any of the aforementioned
|
||
;; delimiters
|
||
(let ((symbol (es:match-regexp "^[^\\s()\"]+"
|
||
trim)))
|
||
(make-token "symbol" symbol trim newpos))))))
|
||
|
||
;; yikes---see notes in docblock with regards to why
|
||
;; we're using mutators here
|
||
(set! toks (append toks (list (car t))))
|
||
(set! src (cadr t))
|
||
(set! pos (caddr t))))))
|
||
toks))
|
||
|
||
|
||
|
||
;; Throw an error with a window of surrounding source code.
|
||
;;
|
||
;; The "window" is simply ten characters to the left and right of the
|
||
;; first character of the source input SRC that resulted in the error.
|
||
;; It's a little more than useless.
|
||
(define (parse-error src pos msg)
|
||
(let ((window (substring src (- pos 10) (+ pos 10))))
|
||
(error (string-append msg " (pos " pos "): " window)
|
||
src)))
|
||
|
||
|
||
|
||
;; Produce a token, left-truncate src, and update pos.
|
||
;;
|
||
;; Unlike the JS Prebirth implementation which uses a key/value object,
|
||
;; we're just using a simple list.
|
||
;;
|
||
;; The expected arguments are: the token type TYPE, the match group or
|
||
;; string MATCH, left-truncated source code SRC, and the position POS
|
||
;; relative to the original source code.
|
||
(define (make-token type match src pos)
|
||
(let* ((parts (if (list? match) match (list match match)))
|
||
(lexeme (car parts))
|
||
;; the value is the first group of the match (indicating what we
|
||
;; are actually interested in), and the lexeme is the full match,
|
||
;; which might include, for example, string delimiters
|
||
(value (or (and (pair? (cdr parts))
|
||
(cadr parts))
|
||
lexeme))
|
||
(len (string-length lexeme)))
|
||
|
||
;; produce token and recurse on `lex', left-truncating the source
|
||
;; string to discard what we have already processed
|
||
(list (list (quote token) type lexeme value pos)
|
||
(substring src len)
|
||
(+ pos len))))
|
||
|
||
|
||
;; various accessor procedures for token lists (we're Prebirth Lisp here,
|
||
;; so no record support or anything fancy!)
|
||
(define (token? t) (and (pair? t) (symbol=? (quote token) (car t))))
|
||
(define (token-type t) (cadr t))
|
||
(define (token-lexeme t) (caddr t))
|
||
(define (token-value t) (cadddr t))
|
||
(define (token-pos t) (caddddr t))
|
||
|
||
|
||
|
||
;; Produce an AST from the given string SRC of sexps
|
||
;;
|
||
;; This is essentially the CST with whitespace removed. It first invokes
|
||
;; the lexer to produce a token string from the input sexps SRC. From this,
|
||
;; it verifies only proper nesting (that SRC does not close sexps too early
|
||
;; and that EOF isn't reached before all sexps are closed) and produces an
|
||
;; AST that is an isomorphism of the original sexps.
|
||
(define (parse-lisp src)
|
||
;; accessor methods to make you and me less confused
|
||
(define (ast-depth ast) (car ast))
|
||
(define (ast-tree ast) (cadr ast))
|
||
(define (ast-stack ast) (caddr ast))
|
||
|
||
|
||
;; perform a leftmost reduction on the token string
|
||
(define (toks->ast toks)
|
||
(fold
|
||
(lambda (token result)
|
||
(let ((depth (ast-depth result))
|
||
(xs (ast-tree result))
|
||
(stack (ast-stack result))
|
||
(type (token-type token))
|
||
(pos (token-pos token)))
|
||
|
||
;; there are very few token types to deal with (again, this is a
|
||
;; very simple bootstrap lisp)
|
||
(case type
|
||
;; ignore comments
|
||
(("comment") result)
|
||
|
||
;; when beginning a new expression, place the expression
|
||
;; currently being processed onto a stack, allocate a new list,
|
||
;; and we'll continue processing into that new list
|
||
(("open") (list (+ depth 1)
|
||
(list)
|
||
(cons xs stack)))
|
||
|
||
;; once we reach the end of the expression, pop the parent off of
|
||
;; the stack and append the new list to it
|
||
(("close") (if (zero? depth)
|
||
(parse-error src pos
|
||
"unexpected closing parenthesis")
|
||
(list (- depth 1)
|
||
(append (car stack) (list xs))
|
||
(cdr stack))))
|
||
|
||
;; strings and symbols (we cheat and just consider everything,
|
||
;; including numbers and such, to be symbols) are just copied
|
||
;; in place
|
||
(("string" "symbol") (list depth
|
||
(append xs (list token))
|
||
stack))
|
||
|
||
;; we should never encounter anything else unless there's a bug
|
||
;; in the tokenizer or we forget a token type above
|
||
(else (parse-error
|
||
src pos (string-append
|
||
"unexpected token `" type "'"))))))
|
||
(list 0 (list) (list)) ; initial 0 depth; empty tree; expr stack
|
||
toks))
|
||
|
||
|
||
;; lex the input SRC and pass it to `toks->ast' to generate the AST;
|
||
;; if the depth is non-zero after we're done, then we're unbalanced.
|
||
(let* ((toks (lex src 0))
|
||
(ast (toks->ast toks)))
|
||
(if (zero? (ast-depth ast))
|
||
(ast-tree ast)
|
||
;; if we terminate at a non-zero depth, that means there ar still
|
||
;; open sexps
|
||
(error (string-append
|
||
"unexpected end of input at depth "
|
||
(ast-depth ast))))))
|
||
|
||
|
||
;; Generate ECMAScript-friendly name from the given id.
|
||
;;
|
||
;; A subset of special characters that are acceptable in Scheme are
|
||
;; converted in an identifiable manner; others are simply converted to `$'
|
||
;; in a catch-all and therefore could result in conflicts and cannot be
|
||
;; reliably distinguished from one-another. Remember: this is temporary
|
||
;; code.
|
||
(define (tname->id name)
|
||
(if (es:match (es:regexp "^\\d+$") name)
|
||
name
|
||
(string-append
|
||
"$$" (es:replace (es:regexp "[^a-zA-Z0-9_]" "g")
|
||
(lambda (c)
|
||
(case c
|
||
(("-") "$_$")
|
||
(("?") "$7$")
|
||
(("@") "$a$")
|
||
(("!") "$b$")
|
||
((">") "$g$")
|
||
(("#") "$h$")
|
||
(("*") "$k$")
|
||
(("<") "$l$")
|
||
(("&") "$n$")
|
||
(("%") "$o$")
|
||
(("+") "$p$")
|
||
(("=") "$q$")
|
||
(("^") "$v$")
|
||
(("/") "$w$")
|
||
(("$") "$$")
|
||
(else "$")))
|
||
name))))
|
||
|
||
;; Join a list of strings XS on a delimiter DELIM
|
||
(define (join delim xs)
|
||
(if (pair? xs)
|
||
(fold (lambda (x str)
|
||
(string-append str delim x))
|
||
(car xs)
|
||
(cdr xs))
|
||
""))
|
||
|
||
|
||
;; Compile parameter list.
|
||
;;
|
||
;; This takes the value of the symbol and outputs it (formatted), delimited
|
||
;; by commas.
|
||
;;
|
||
;; Since we do not support actual pairs (yet), the "." syntax that normally
|
||
;; denotes the cdr is retained and presents itself here. The form "(arg1,
|
||
;; arg2 . rest)" creates a list `rest' containing all remaining arguments
|
||
;; after that point. Conveniently, ECMAScript Harmony supports this
|
||
;; natively with the "..." syntax.
|
||
(define (params->es params)
|
||
(define (%param-conv params)
|
||
(let* ((param (car params))
|
||
(name (token-value param))
|
||
(id (tname->id name))
|
||
(rest (cdr params)))
|
||
(if (string=? name ".")
|
||
(list (string-append
|
||
"..." (car (%param-conv rest))))
|
||
(if (pair? rest)
|
||
(cons id (%param-conv rest))
|
||
(list id)))))
|
||
|
||
(if (pair? params)
|
||
(join "," (%param-conv params))
|
||
""))
|
||
|
||
|
||
;; Compile body s-expressions into ECMAScript
|
||
;;
|
||
;; This produces a 1:1 mapping of body XS s-expressions to ES statements,
|
||
;; recursively. The heavy lifting is done by `sexp->es'.
|
||
(define (body->es xs ret)
|
||
;; recursively process body XS until we're out of pairs
|
||
(if (not (pair? xs))
|
||
""
|
||
(let* ((x (car xs))
|
||
(rest (cdr xs))
|
||
(more? (or (not ret) (pair? rest))))
|
||
;; the result is a semicolon-delimited string of statements, with
|
||
;; the final statement prefixed with `return' unless (not ret)
|
||
(string-append
|
||
" "
|
||
(if more? "" "return ") ; prefix with `return' if last body exp
|
||
(sexp->es x) ";" ; process current body expression
|
||
(if (pair? rest) "\n" "")
|
||
(body->es rest ret))))) ; recurse
|
||
|
||
|
||
;; Compile variable or procedure definition into ES
|
||
;;
|
||
;; This performs a crude check to determine whether a procedure definition
|
||
;; was supplied: if the cadr of the given token T is itself token, then it
|
||
;; is considered to be a variable.
|
||
(define (cdfn t)
|
||
(if (token? (cadr t))
|
||
(cdfn-var t) ;; (define foo ...)
|
||
(cdfn-proc t #f))) ;; (define (foo ...) ...)
|
||
|
||
|
||
;; Compile variable definition into ES
|
||
;;
|
||
;; This compiles the token T into a simple let-assignment.
|
||
(define (cdfn-var t)
|
||
(let* ((dfn (cadr t))
|
||
(id (tname->id (token-value dfn)))
|
||
(value (sexp->es (caddr t))))
|
||
(string-append "let " id "=" value)))
|
||
|
||
|
||
;; Compile procedure definition into an ES function definition
|
||
;;
|
||
;; This will fail if the given token is not a `define'.
|
||
(define (cdfn-proc t id-override)
|
||
;; e.g. (define (foo ...) body)
|
||
(let* ((dfn (cadr t))
|
||
(id (or id-override
|
||
(tname->id (token-value (car dfn)))))
|
||
(params (params->es (cdr dfn)))
|
||
(body (body->es (cddr t) #t)))
|
||
;; this is the final format---each procedure becomes its own function
|
||
;; definition in ES
|
||
(string-append
|
||
"function " id "(" params ")\n{\n" body "\n}")))
|
||
|
||
|
||
;; Quote an expression
|
||
;;
|
||
;; If SEXP is a token, produce an ECMAScript Symbol. Otherwise,
|
||
;; recursively apply to each element in the list.
|
||
;;
|
||
;; TODO: This implementation isn't wholly correct---numbers, for example,
|
||
;; should not be converted to symbols, as they already are one.
|
||
(define (quote-sexp sexp)
|
||
(if (token? sexp)
|
||
(case (token-type sexp)
|
||
(("string") (sexp->es sexp))
|
||
(else
|
||
(string-append "Symbol.for('" (token-value sexp) "')")))
|
||
(string-append
|
||
"[" (join "," (map quote-sexp sexp)) "]")))
|
||
|
||
|
||
;; Quasiquote an expression
|
||
;;
|
||
;; A quasiquoted expression acts just like a quoted expression with one
|
||
;; notable exception---quoting can be escaped using special forms. For
|
||
;; example, each of these are equivalent:
|
||
;;
|
||
;; (quasiquote (a 1 2 (unquote (eq? 3 4))))
|
||
;; (list (quote a) 1 2 (eq? 3 4))
|
||
;; (quasiquote (a (unquote-splicing (list 1 2)) (unquote (eq? 3 4))))
|
||
;;
|
||
;; TODO/WARNING: Normally "(quasiquote a (unquote-splicing b))" would
|
||
;; produce "(a . b)" in a proper Lisp, but we do not yet support proper
|
||
;; pairs at the time that this procedure was written; all cdrs are assumed
|
||
;; to be lists. So do not do that---always splice lists.
|
||
(define (quasiquote-sexp sexp)
|
||
;; get type of token at car of pair, unless not a pair
|
||
(define (%sexp-maybe-type sexp)
|
||
(and (pair? sexp)
|
||
(token? (car sexp))
|
||
(token-value (car sexp))))
|
||
|
||
;; recursively process the sexp, handling various types of unquoting
|
||
(define (%quote-maybe sexp delim)
|
||
(if (pair? sexp)
|
||
(let* ((item (car sexp))
|
||
(rest (cdr sexp))
|
||
(type (%sexp-maybe-type item))
|
||
(add-delim (not (or (string=? type "unquote-splicing")
|
||
(string=? type "unquote@")))))
|
||
(string-append
|
||
(case type
|
||
;; escape quoting, nest within
|
||
(("unquote")
|
||
(string-append (if delim "," "")
|
||
(sexp->es (cadr item))))
|
||
|
||
;; escape quoting, splice list into parent expression
|
||
;; (lazy kluge warning), along with an alias for brevity
|
||
;; given that we lack the ",@" syntax right now
|
||
(("unquote-splicing" "unquote@")
|
||
(string-append
|
||
"]).concat(" (sexp->es (cadr item)) ").concat(["))
|
||
|
||
;; anything else, we're still quasiquoting recursively
|
||
(else (string-append (if delim "," "")
|
||
(quasiquote-sexp item))))
|
||
|
||
;; continue processing this list
|
||
(%quote-maybe rest add-delim)))
|
||
""))
|
||
|
||
;; tokens fall back to normal quoting
|
||
(if (token? sexp)
|
||
(quote-sexp sexp)
|
||
(string-append
|
||
"([" (%quote-maybe sexp #f) "])")))
|
||
|
||
|
||
;; Statically expand expressions based on implementation features
|
||
;;
|
||
;; Support for `cond-expand' allows Rebirth to introduce new features each
|
||
;; time that it is compiled. If matched, expressions will be evaluated as
|
||
;; if they were entered in place of the `cond-expand' itself; otherwise,
|
||
;; the entire `cond-expand' expression as a whole will be discarded.
|
||
;;
|
||
;; Birth will always discard `cond-expand' expressions unless they contain
|
||
;; an `else' clause, which permits us to compile on the first pass without
|
||
;; error.
|
||
(define (expand-cond-expand args)
|
||
(if (pair? args)
|
||
(let* ((clause (car args))
|
||
(feature (token-value (car clause)))
|
||
(body (cdr clause)))
|
||
;; now we get meta
|
||
(cond-expand
|
||
(string->es
|
||
(case feature
|
||
(("string->es" "else") (body->es body #f))
|
||
(else (if (es:defined? feature)
|
||
(body->es body #f)
|
||
(expand-cond-expand (cdr args))))))
|
||
;; if we're not yet compiled with Rebirth, then string->es will
|
||
;; not yet be available---but it _will_ be in Rebirth, so
|
||
;; compile cond-expand such that it marks it as supported
|
||
(else
|
||
(case feature
|
||
;; these two are always supported in Rebirth Lisp
|
||
(("string->es" "else") (body->es body #f))
|
||
;; keep recursing until we find something (this allows us to
|
||
;; short-circuit, most notably with "else")
|
||
(else
|
||
(expand-cond-expand (cdr args)))))))
|
||
""))
|
||
|
||
|
||
;; Determine whether the given name NAME represents a macro.
|
||
;;
|
||
;; If `string->es' is not yet supported, then this procedure always
|
||
;; yields `#f'. Otherwise, the compiler runtime `_macros' is consulted.
|
||
;;
|
||
;; See `cdfn-macro' for more information.
|
||
(define (macro? name)
|
||
(cond-expand
|
||
(string->es
|
||
(string->es "_macros[$$name] !== undefined"))
|
||
(else #f)))
|
||
|
||
|
||
;; Determine if FN is a procedure or macro and apply it accordingly with
|
||
;; arguments ARGS.
|
||
;;
|
||
;; These actions represent two separate environments: If a macro, then the
|
||
;; call needs to be executed immediately within the context of the compiler
|
||
;; runtime. Otherwise, procedure applications are simply compiled to be
|
||
;; produced with the rest of the compiler output and will be run at a later
|
||
;; time within the context of the compiled program.
|
||
(define (apply-proc-or-macro fn args)
|
||
(if (macro? fn)
|
||
(string->es "_macros[$$fn].apply(null,$$args)")
|
||
;; Procedures are produced as part of the compiler output.
|
||
(let* ((idfn (tname->id fn))
|
||
(argstr (join ", " (map sexp->es args))))
|
||
(string-append idfn "(" argstr ")"))))
|
||
|
||
|
||
;; Primitive special forms.
|
||
;;
|
||
;; These are forms that cannot be re-written as macros because of
|
||
;; chicken-and-egg issues. Since the Rebirth compiler is temporary, we're
|
||
;; not going to worry about getting rid of the rest of these.
|
||
;;
|
||
;; String values are simple function aliases. Function values take over
|
||
;; the compilation of that function and allow for defining special forms
|
||
;; (in place of macro support). The first argument FN is the name of the
|
||
;; function/procedure/form, and ARGS is the list of arguments.
|
||
(define (fnmap fn args t)
|
||
(case fn
|
||
;; output raw code into the compiled ECMAScript (what could go wrong?)
|
||
(("string->es")
|
||
(token-value (car args)))
|
||
|
||
;; very primitive cond-expand
|
||
(("cond-expand") (expand-cond-expand args))
|
||
|
||
;; Note that the unquote forms are only valid within a quasiquote; see
|
||
;; that procedure for the handling of those forms. Since we do not
|
||
;; support the special prefix form, we also offer "`quote" as a
|
||
;; shorthand for quasiquote.
|
||
(("quote") (quote-sexp (car args)))
|
||
(("quasiquote" "`quote") (quasiquote-sexp (car args)))
|
||
|
||
(("define") (cdfn t))
|
||
(("define-macro") (cdfn-macro t)) ; not defined until string->es cond
|
||
|
||
;; If we have macro support (`cdfn-macro'), then assume that they exist
|
||
;; and try to use them; otherwise, continue to use built-in forms, which
|
||
;; have been moved into `fnmap-premacro').
|
||
(else
|
||
(cond-expand
|
||
(cdfn-macro (apply-proc-or-macro fn args))
|
||
(else (fnmap-premacro fn args t))))))
|
||
|
||
|
||
;; Special forms to be removed on future Rebirth pass in favor of macros
|
||
;;
|
||
;; See Step 2 above for the replacement macro definitions.
|
||
(cond-expand
|
||
(cdfn-macro) ; our cond-expand does not support `else'
|
||
(else
|
||
(define (fnmap-premacro fn args t)
|
||
(case fn
|
||
(("es:console")
|
||
(string-append "console.log(" (map sexp->es args) ")"))
|
||
(("es:error")
|
||
(string-append "console.error(" (map sexp->es args) ")"))
|
||
|
||
;; yes, there are more important things to do until we get to the
|
||
;; point where it's worth implementing proper tail calls
|
||
(("es:while")
|
||
(let ((pred (car args))
|
||
(body (cdr args)))
|
||
(string-append
|
||
"(function(__whilebrk){"
|
||
"while (" (sexp->es pred) "){\n"
|
||
(body->es body #f) " if (__whilebrk) break;\n"
|
||
"}\n"
|
||
"})(false)")))
|
||
(("es:break") "__whilebrk=true")
|
||
|
||
(("lambda")
|
||
(let ((fnargs (car args))
|
||
(body (cdr args)))
|
||
(string-append
|
||
"function(" (join ", " (map sexp->es fnargs)) "){\n"
|
||
(body->es body #t)
|
||
"}")))
|
||
|
||
;; simple if statement with optional else, wrapped in a self-executing
|
||
;; function to simplify code generation (e.g. returning an if)
|
||
(("if")
|
||
(let ((pred (car args))
|
||
(t (cadr args))
|
||
(f (and (pair? (cddr args))
|
||
(caddr args))))
|
||
(string-append
|
||
"(function(){"
|
||
"if (_truep(" (sexp->es pred) ")){return " (sexp->es t) ";}"
|
||
(or (and (pair? f)
|
||
(string-append "else{return " (sexp->es f) ";}"))
|
||
"")
|
||
"})()")))
|
||
|
||
;; and short-circuits, so we need to implement it as a special form
|
||
;; rather than an alias
|
||
(("and")
|
||
(string-append
|
||
"(function(__and){\n"
|
||
(join "" (map (lambda (expr)
|
||
(string-append
|
||
"__and = " (sexp->es expr) "; "
|
||
"if (!_truep(__and)) return false;\n"))
|
||
args))
|
||
"return __and;})()"))
|
||
|
||
;; or short-circuits, so we need to implement it as a special form
|
||
;; rather than an alias
|
||
(("or")
|
||
(string-append
|
||
"(function(__or){\n"
|
||
(join "" (map (lambda (expr)
|
||
(string-append
|
||
"__or = " (sexp->es expr) "; "
|
||
"if (_truep(__or)) return __or;\n"))
|
||
args))
|
||
"return false;})()"))
|
||
|
||
;; (let ((binding val) ...) ...body), compiled as a self-executing
|
||
;; function which allows us to easily represent the return value of
|
||
;; the entire expression while maintaining local scope.
|
||
(("let*")
|
||
(let ((bindings (car args))
|
||
(body (cdr args)))
|
||
(string-append
|
||
"(function(){\n"
|
||
(join "" (map (lambda (binding)
|
||
(string-append
|
||
" let " (sexp->es (car binding))
|
||
" = " (sexp->es (cadr binding)) ";\n"))
|
||
bindings))
|
||
(body->es body #t) "\n"
|
||
" })()")))
|
||
|
||
;; similar to the above, but variables cannot reference one-another
|
||
(("let")
|
||
(let* ((bindings (car args))
|
||
(body (cdr args))
|
||
(fparams (join ", " (map sexp->es
|
||
(map car bindings))))
|
||
(fargs (join ", " (map sexp->es
|
||
(map cadr bindings)))))
|
||
(string-append "(function(" fparams "){\n"
|
||
(body->es body #t) "\n"
|
||
"})(" fargs ")")))
|
||
|
||
;; and here I thought Prebirth Lisp would be simple...but having
|
||
;; `case' support really keeps things much more tidy, so here we are
|
||
;; (note that it doesn't support the arrow form, nor does it support
|
||
;; expressions as data)
|
||
(("case")
|
||
(let ((key (car args))
|
||
(clauses (cdr args)))
|
||
(string-append
|
||
"(function(){const _key=" (sexp->es key) ";\n"
|
||
"switch (_key){\n"
|
||
(join ""
|
||
(map (lambda (data exprs)
|
||
(string-append
|
||
(if (and (token? data)
|
||
(string=? "else" (token-lexeme data)))
|
||
"default:\n"
|
||
(join ""
|
||
(map (lambda (datum)
|
||
(string-append
|
||
"case " (sexp->es datum) ":\n"))
|
||
data)))
|
||
(body->es exprs #t) "\n"))
|
||
(map car clauses)
|
||
(map cdr clauses)))
|
||
"}})()")))
|
||
|
||
(("set!")
|
||
(let ((varid (car args))
|
||
(val (cadr args)))
|
||
(string-append (sexp->es varid) " = " (sexp->es val))))
|
||
|
||
;; procedure or macro
|
||
(else (apply-proc-or-macro fn args))))))
|
||
|
||
|
||
;; Convert s-expressions or scalar into ECMAScript
|
||
;;
|
||
;; T may be either an array of tokens or a primitive token (e.g. string,
|
||
;; symbol). This procedure is applied recursively to T as needed if T is
|
||
;; a list.
|
||
(define (sexp->es t)
|
||
(if (not (list? t))
|
||
(error "unexpected non-list for sexp->es token"))
|
||
|
||
(if (token? t)
|
||
(case (token-type t)
|
||
;; strings output as-is (note that we don't escape double quotes,
|
||
;; because the method of escaping them is the same in Scheme as it
|
||
;; is in ECMAScript---a backslash)
|
||
(("string") (string-append "\"" (token-value t) "\""))
|
||
|
||
;; symbols have the same concerns as procedure definitions: the
|
||
;; identifiers generated need to be ES-friendly
|
||
(("symbol") (tname->id (token-value t)))
|
||
|
||
(else (error
|
||
(string-append
|
||
"cannot compile unknown token `" (token-type t) "'"))))
|
||
|
||
;; otherwise, process the expression
|
||
(fnmap (token-value (car t))
|
||
(cdr t)
|
||
t)))
|
||
|
||
|
||
;; Compile Rebirth Lisp AST into ECMAScript.
|
||
;;
|
||
;; The AST can be generated with `parse-lisp'.
|
||
(define (rebirth->ecmascript ast)
|
||
;; compiled output, wrapped in a self-executing function to limit scope
|
||
;; (note that we no longer depend on libprebirth)
|
||
(string-append "(function(){"
|
||
(join "\n\n" (map sexp->es ast))
|
||
"})();"))
|
||
|
||
|
||
;; at this point, this program can parse itself and output a CST (sans
|
||
;; whitespace)
|
||
(es:console (rebirth->ecmascript
|
||
(parse-lisp
|
||
(es:file->string "/dev/stdin"))))
|