|
|
|
@ -28,19 +28,198 @@
|
|
|
|
|
;;; 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. So steps will follow as development continues.
|
|
|
|
|
;;; Scheme compiler. Rebirth may as well be called Rerebirth, or
|
|
|
|
|
;;; Rererebirth, 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.csm', modified to introduce additional
|
|
|
|
|
;;; 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).
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; 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")
|
|
|
|
|
|
|
|
|
|
(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)
|
|
|
|
|
(es:arg->arr (string->es "arguments")))
|
|
|
|
|
|
|
|
|
|
;; 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)
|
|
|
|
|
(fold (lambda (x xs)
|
|
|
|
|
(es:-assert-list x)
|
|
|
|
|
(string->es "$$xs.concat($$x)"))
|
|
|
|
|
(list)
|
|
|
|
|
(es:arg->arr (string->es "arguments"))))
|
|
|
|
|
|
|
|
|
|
;; 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)
|
|
|
|
|
(let ((args (es:arg->arr (string->es "arguments"))))
|
|
|
|
|
(string->es "$$args.join('')")))
|
|
|
|
|
|
|
|
|
|
(define (eq? x y)
|
|
|
|
|
(string->es "$$x === $$y"))
|
|
|
|
|
|
|
|
|
|
;; R7RS math
|
|
|
|
|
(define (+)
|
|
|
|
|
(let ((args (es:arg->arr (string->es "arguments"))))
|
|
|
|
|
(fold (lambda (y x)
|
|
|
|
|
(string->es "$$x + $$y"))
|
|
|
|
|
0
|
|
|
|
|
args)))
|
|
|
|
|
(define (-)
|
|
|
|
|
(let ((args (es:arg->arr (string->es "arguments"))))
|
|
|
|
|
(fold (lambda (y x)
|
|
|
|
|
(string->es "$$x - $$y"))
|
|
|
|
|
(car args)
|
|
|
|
|
(cdr args))))
|
|
|
|
|
(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
|
|
|
|
|
;; (we implement this in ES for now so that we don't have to augment
|
|
|
|
|
;; Prebirth Lisp to support the "rest" procedure definition syntax)
|
|
|
|
|
(define (map f)
|
|
|
|
|
(string->es "__a = arguments") ; because let introduces a function
|
|
|
|
|
(let* ((args (es:arg->arr (string->es "__a")))
|
|
|
|
|
(xs (cdr args)))
|
|
|
|
|
(string->es
|
|
|
|
|
"$$xs[0].map((_, i) => $$f.apply(null, $$xs.map(x => x[i])))")))
|
|
|
|
|
|
|
|
|
|
(define (js:regexp s opts)
|
|
|
|
|
(string->es "new RegExp($$s, $$opts)"))
|
|
|
|
|
(define (js:match r s)
|
|
|
|
|
(string->es "$$s.match($$r) || false"))
|
|
|
|
|
(define (js: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 (js:file->string path)
|
|
|
|
|
(if (string->es "fsdata[$$path] === undefined")
|
|
|
|
|
(string->es
|
|
|
|
|
"fsdata[$$path] = fs.readFileSync($$path).toString()")
|
|
|
|
|
(string->es "fsdata[$$path]")))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; pair selection
|
|
|
|
|
(define (cadr xs)
|
|
|
|
|
(car (cdr xs)))
|
|
|
|
@ -112,8 +291,9 @@
|
|
|
|
|
;; strings are delimited by opening and closing ASCII
|
|
|
|
|
;; double quotes, which can be escaped with a
|
|
|
|
|
;; backslash
|
|
|
|
|
(("\"") (let ((str (js:match-regexp "^\"(|.*?[^\\\\])\""
|
|
|
|
|
trim)))
|
|
|
|
|
(("\"") (let ((str (js:match-regexp
|
|
|
|
|
"^\"(|(?:.|\\\n)*?[^\\\\])\""
|
|
|
|
|
trim)))
|
|
|
|
|
(or str (parse-error
|
|
|
|
|
src pos
|
|
|
|
|
"missing closing string delimiter"))
|
|
|
|
@ -340,10 +520,31 @@
|
|
|
|
|
(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))) ;; (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 t)
|
|
|
|
|
(define (cdfn-proc t)
|
|
|
|
|
;; e.g. (define (foo ...) body)
|
|
|
|
|
(let* ((dfn (cadr t))
|
|
|
|
|
(id (tname->id (token-value (car dfn))))
|
|
|
|
@ -376,6 +577,21 @@
|
|
|
|
|
(case fn
|
|
|
|
|
(("js:console")
|
|
|
|
|
(string-append "console.log(" (map sexp->es args) ")"))
|
|
|
|
|
(("js:error")
|
|
|
|
|
(string-append "console.error(" (map sexp->es args) ")"))
|
|
|
|
|
|
|
|
|
|
;; very primitive cond-expand
|
|
|
|
|
(("cond-expand")
|
|
|
|
|
(let* ((clause (car args))
|
|
|
|
|
(feature (token-value (car clause)))
|
|
|
|
|
(body (cdr clause)))
|
|
|
|
|
(case feature
|
|
|
|
|
(("string->es") (body->es body #f))
|
|
|
|
|
(else ""))))
|
|
|
|
|
|
|
|
|
|
;; output raw code into the compiled ECMAScript (what could go wrong?)
|
|
|
|
|
(("string->es")
|
|
|
|
|
(token-value (car args)))
|
|
|
|
|
|
|
|
|
|
;; yes, there are more important things to do until we get to the
|
|
|
|
|
;; point where it's worth implementing proper tail calls
|
|
|
|
@ -541,10 +757,9 @@
|
|
|
|
|
(cdr t)
|
|
|
|
|
t)))
|
|
|
|
|
|
|
|
|
|
;; output libprebirth and compiled output, wrapped in a self-executing
|
|
|
|
|
;; function to limit scope
|
|
|
|
|
;; compiled output, wrapped in a self-executing function to limit scope
|
|
|
|
|
;; (note that we no longer depend on libprebirth)
|
|
|
|
|
(string-append "(function(){"
|
|
|
|
|
(js:file->string "libprebirth.js") "\n\n"
|
|
|
|
|
(join "\n\n" (map sexp->es ast))
|
|
|
|
|
"})();"))
|
|
|
|
|
|
|
|
|
|