ulambda/build-aux/bootstrap/rebirth/es.scm

;;; ECMAScript Target Compiler Macros for Rebirth Lisp
;;;
;;;  Copyright (C) 2017, 2018 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 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'.  For now, anyway---that's the easy solution for now, but
;;; in the future (Ulambda) we're likely to have a heap instead, once we have
;;; static analysis.
;;;
;;; 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))))

   ;; Expand the body BODY into a new environment inherited from the current
   ;; environment.  Environments are currently handled by the ES runtime, so
   ;; this is easy.
   (define-macro (es:envf . body)
     (`quote
      (string-append
       "(function(_env){"
       "return "
       (unquote@ body)
       "})(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")

   ;; 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
      "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
                       "(function(" fparams "){\n"
                       (env-params params)
                       (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)))
     "}})()")

   ;; 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))))))