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

;;; libprebirth Replacement 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/>.
;;;
;;; THIS IS BOOTSTRAP CODE INTENDED FOR USE ONLY IN REBIRTH.
;;;
;;;
;;;                           === STEP 0 ===
;;;
;;; 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:null? x)
     (string->es "$$x === null"))

   (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 "+$$x > +$$y"))
   (define (< x y)
     (string->es "+$$x < +$$y"))

   ;; 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)
          (not (zero? (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-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]")))))