445 lines
16 KiB
Scheme
445 lines
16 KiB
Scheme
;;;; ECMAScript Target Compiler Macros for Rebirth Lisp
|
||
;;;;
|
||
;;;; Copyright (C) 2017, 2018 Mike Gerwitz
|
||
;;;;
|
||
;;;; This file is part of Ulambda Scheme.
|
||
;;;;
|
||
;;;; Ulambda Scheme 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/>.
|
||
;;;;
|
||
|
||
|
||
|
||
;;; Commentary:
|
||
|
||
;;; THIS IS BOOTSTRAP CODE INTENDED FOR USE ONLY IN REBIRTH.
|
||
;;;
|
||
;;;
|
||
;;; === STEP 2 ===
|
||
;;;
|
||
;;; Did you read the other steps first? If not, you're out of order; go to
|
||
;;; Step 0 first and then come back here; see `rebirth.scm'.
|
||
;;;
|
||
;;; 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.
|
||
;;;
|
||
;;; These macros have references to `_env', representing the current
|
||
;;; environment. It is at this point that we also add primitive environment
|
||
;;; support---this is essential as we move forward into purely macro-based
|
||
;;; compilation passes, since we need to be able to have discrete
|
||
;;; environments to run each of those passes in. More on that later.
|
||
;;;
|
||
;;; Scheme creates a new environment for every level of scope. Each
|
||
;;; environment inherits the one above it, which produces the familiar
|
||
;;; lexical scoping. As it turns out, this structure is represented
|
||
;;; perfectly by ECMAScript's prototype model---a reference to a key on a
|
||
;;; prototype chain is transparently proxied up the chain until it is
|
||
;;; found. Therefore, environments are chained using a simple
|
||
;;; `Object.create'. This creates a data structure similar to a spaghetti
|
||
;;; stack.
|
||
;;;
|
||
;;; 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.
|
||
;;;
|
||
|
||
;;; Code:
|
||
|
||
|
||
|
||
;; Pair selection (these were part of birth.scm).
|
||
(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)))
|
||
|
||
|
||
|
||
;; An empty environment.
|
||
;;
|
||
;; This holds a reference to itself as `root' so that we can access the top
|
||
;; of the prototype chain easily. The reason for this is a kluge to give
|
||
;; macros access to procedures as they are defined (without having to wait
|
||
;; until the execution of a new version of rebirth). See `cdfn-proc'.
|
||
(define (es:empty-env)
|
||
"(function(){let o = {macros:{}}; o.root = o; return o;})()")
|
||
|
||
|
||
|
||
(cond-expand
|
||
(cdfn-macro
|
||
;; We have macro support, so we can substitute the original Birth
|
||
;; definitions with macro equivalents.
|
||
|
||
(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 (es:json-stringify value)
|
||
(string->es "JSON.stringify($$value)"))
|
||
|
||
;; Expand the body BODY into a new environment. Environments are
|
||
;; currently handled by the ES runtime, so this is easy.
|
||
(define-macro (es:envf env . body)
|
||
(`quote
|
||
(string-append
|
||
"(function(_env){"
|
||
"return "
|
||
(unquote@ body)
|
||
"})(" (unquote env) ")")))
|
||
|
||
(define (es:inherit-env)
|
||
"Object.create(_env)")
|
||
|
||
(define-macro (define-es-macro decl . body)
|
||
(quasiquote
|
||
(define-macro (unquote decl)
|
||
(list
|
||
(quote string->es)
|
||
(string-append (unquote@ body))))))
|
||
|
||
;; Reference to current environment object.
|
||
(define-es-macro (%es:env) "_env")
|
||
|
||
;; Simple macro to encapsulate an expression in a try/catch and avoid
|
||
;; having to implement anything more complicated atm.
|
||
(define-es-macro (es:try try else)
|
||
"(function(){try{return " (sexp->es try) ";}"
|
||
"catch(e){return " (sexp->es else) "(e.message);}})()")
|
||
|
||
;; 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)
|
||
(es:envf (es:inherit-env)
|
||
"function(" (join ", " (map tparam->es fnargs)) "){\n"
|
||
(env-params fnargs)
|
||
(body->es body #t)
|
||
"}"))
|
||
|
||
(define-es-macro (let* bindings . body)
|
||
"(function(){\n"
|
||
(join "" (map (lambda (binding)
|
||
(string-append
|
||
"let " (tparam->es (car binding)) ; TODO: BC; remove
|
||
" = " (env-ref (car binding))
|
||
" = " (sexp->es (cadr binding)) ";\n"))
|
||
bindings))
|
||
(body->es body #t) "\n"
|
||
" })()")
|
||
|
||
(define-es-macro (let bindings . body)
|
||
(let* ((params (map car bindings))
|
||
(fparams (join ", " (map tparam->es params)))
|
||
(args (map cadr bindings))
|
||
(fargs (map sexp->es args)))
|
||
(string-append (es:envf (es:inherit-env)
|
||
"(function(" fparams "){\n"
|
||
(env-params params)
|
||
(body->es body #t) "\n"
|
||
"})(" fargs ")"))))
|
||
|
||
(define-es-macro (and . args)
|
||
"(function(__and){\n"
|
||
"__and = true; "
|
||
(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)))
|
||
"}})()")
|
||
|
||
;; this was part of birth.scm
|
||
(define (not x)
|
||
(if x #f #t))
|
||
|
||
;; We can just re-use `let' for `begin' since it already does exactly
|
||
;; what we need it to
|
||
(define-macro (begin . exprs)
|
||
(`quote (let () (unquote@ exprs))))
|
||
|
||
|
||
;; This doesn't currently produce any sort of encapsulated
|
||
;; environment---it just produces an ECMAScript string. This also
|
||
;; does not provide any of the expected syntatic keywords yet.
|
||
(define (null-environment version)
|
||
(if (not (eq? version 5))
|
||
(error "null-environment version must be 5")
|
||
(es:empty-env)))
|
||
|
||
;; `eval' re-uses the macro `list->ast' procedure, immediately applying
|
||
;; its result.
|
||
(define-macro (eval expr env)
|
||
(`quote (%es:native-apply
|
||
eval
|
||
(es:envf (unquote env)
|
||
(sexp->es (list->ast (unquote expr)))))))
|
||
|
||
|
||
;; We unfortunately have to worry about environment mutability in the
|
||
;; current implementation. Since variables within environments are
|
||
;; implemented using ECMAScript's prototype chain, any sets affect the
|
||
;; object that the assignment is performed _on_, _not_ the prototype that
|
||
;; contains the key being set. Therefore, we have to traverse up the
|
||
;; prototype chain until we find the correct value, and set it on that
|
||
;; object.
|
||
;;
|
||
;; There are other ways to accomplish this. For example, we should
|
||
;; define setters for each variable and then not worry about
|
||
;; traversing. However, since set! is rare, we wouldn't want to incur a
|
||
;; performance hit for every single variable.
|
||
(define (%es:has-own-prop o id)
|
||
(string->es "Object.hasOwnProperty.call($$o, $$id)"))
|
||
(define (%es:proto-of o)
|
||
(string->es "Object.getPrototypeOf($$o)"))
|
||
(define (%es:envobj-for env id)
|
||
(if (and (string=? (es:typeof env) "object")
|
||
(not (es:null? env)))
|
||
(if (%es:has-own-prop env id)
|
||
env
|
||
(%es:envobj-for (%es:proto-of env) id))
|
||
(error (string-append "unknown variable: `" id "'"))))
|
||
(define (%es:setenv env id val)
|
||
(let ((envo (%es:envobj-for env id)))
|
||
(string->es "$$envo[$$id] = $$val")))
|
||
|
||
;; set! is then a simple application of `%es:setenv'.
|
||
(define-macro (set! varid val)
|
||
(`quote
|
||
(%es:setenv (%es:env)
|
||
(unquote (tname->id (token-lexeme varid)))
|
||
(unquote val)))))
|
||
|
||
|
||
|
||
(else
|
||
;; We do _not_ have macro support, so fall back to the original
|
||
;; definitions used by Birth.
|
||
(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))))
|
||
|
||
;; This was part of birth.scm. This is included here in the `else'
|
||
;; clause because it is defined using `if': On early Rebirth passes,
|
||
;; `if' is built into the compiler and so it is available
|
||
;; immediately. But on future passes, `if' is defined in this file, and
|
||
;; so we cannot define `not' until that point (see the duplicate
|
||
;; definition of `not' above).
|
||
(define (not x)
|
||
(if x #f #t))))
|