`(Hello ,world)

plan

はてなダイアリーを見て「その通りだよなぁ」と思い、自分を省みるとまるで方向感がなくて右往左往してるだけなので凹む。

• 知識とか技術とか。 - 簡潔なQ

Scheme->JavaScriptコンパイラ

JavaScript上で動くScheme処理系はBiwaSchemeとかいろいろあるけど、SchemeのソースをJavaScriptにコンパイルして実行してやったらレイヤーを一段減らせてお得かなーGoogle Chromeだと速いかなーと思った。でもすでにあった（Scheme2Js）。でもでかくでわからんので自分でやる。

動作デモ。フィボナッチとかは動いた。

以下ソース：コンパイラ

;;;; Scheme -> JavaScript compiler 

(define (scm2js s env) 
  (if (not (pair? s))
      (cond ((symbol? s) (ref-env s env))
            (else (literal->string s)))
    (cond ((special-form? s) => (lambda (fn) (fn s env)))
          (else (compile-funcall s env)))))

(define (literal->string s)
  (cond ((string? s) (string-append "\"" s "\""))
        ((number? s) (number->string s))
        ((null? s)   "null")
        ((eq? s #t)  "true")
        ((eq? s #f)  "false")
        (else (error "literal->string"))))

(define (ref-env sym env)
  (scm->js-symbol sym))

(define (scm->js-symbol sym)
  (apply string-append (map (lambda (c)
                              (if (js-sym-char c)
                                  (string c)
                                (string-append "_"
                                               (integer->hex-string (char->integer c) 2))))
                            (string->list (symbol->string sym)))))

(define (js-sym-char c)
  (or (is-alnum c)
      (eq? c #\_)))

(define (is-alnum c)
  (or (is-alpha c) (is-num c)))

(define (is-alpha c)
  (or (and (char<=? #\a c) (char<=? c #\z))
      (and (char<=? #\A c) (char<=? c #\Z))))

(define (is-num c)
  (and (char<=? #\0 c) (char<=? c #\9)))

(define (integer->hex-string ascii keta)
;  (format #`"~,|keta|,,'0X" ascii))
  (number->string ascii))

(define (special-form? s)
  (case (car s)
    ((quote)  compile-quote)
    ((lambda) compile-lambda)
    ((if)     compile-if)
    ((define) compile-define)
    (else #f)))

(define (compile-quote s env)
  (define (make-cons x)
    (scm2js `(cons (quote ,(car x)) (quote ,(cdr x))) env))
  (let ((x (cadr s)))
    (if (pair? x)
        (make-cons x)
      (if (not (symbol? x))
          (literal->string x)
        x))))

(define (compile-lambda s env)
  (let ((parm (cadr s))
        (body (cddr s)))
    (string-append "(function ("
                   (expand-args parm env)
                   ") { "
                   (expand-body body env)
                   " })")))

(define (expand-body body env)
  (cond ((null? body) "")
        ((null? (cdr body)) (string-append "return "
                                           (scm2js (car body) env)))
        (else
         (string-append (string-join (map (lambda (s) (scm2js s env))
                                          (butlast body))
                                     "; ")
                        "; return "
                        (scm2js (car (last-pair body)) env)))))

(define (last-pair ls)  ; for BiwaScheme
  (cond ((null? ls) ls)
        ((null? (cdr ls)) ls)
        (else (last-pair (cdr ls)))))

(define (butlast ls)
  (cond ((null? ls) ls)
        ((null? (cdr ls)) '())
        (else (cons (car ls) (butlast (cdr ls))))))

(define (compile-if s env)
  (let ((p (cadr s))
        (th (caddr s))
        (el (cdddr s)))
    (string-append "(scmtrue("
                   (scm2js p env)
                   ") ? ("
                   (scm2js th env)
                   ") : ("
                   (if (not (null? el))
                       (scm2js (car el) env)
                     "undefined")
                   "))")))

(define (compile-define s env)
  (let ((name (cadr s))
        (body (cddr s)))
    (if (pair? name)
        (compile-define `(define ,(car name) (lambda ,(cdr name) ,@body)) env)
      (string-append (ref-env name env)
                     " = "
                     (scm2js (car body) env)))))

(define (compile-funcall s env)
  (let ((fn (car s))
        (args (cdr s)))
    (if (operator? fn)
        (prefix->infix fn args env)
      (string-append (make-function fn env)
                     "("
                     (expand-args args env)
                     ")"))))

(define (make-function fn env)
  (scm2js fn env))

(define (expand-args args env)
  (string-join (map (lambda (x) (scm2js x env))
                    args)
               ", "))

(define (prefix->infix op raw-args env)
  (let ((opstr (string-append " " (symbol->string op) " "))
        (args (map (lambda (x) (scm2js x env)) raw-args)))
    (cond ((and (eq? op '-) (single? args)) (string-append "-" (car args)))
          ((and (eq? op '/) (single? args)) (string-append "1/" (car args)))
          ((cmp-op? op) (string-append "(("
                                       (string-join (map (lambda (ls)
                                                           (string-append (car ls)
                                                                          opstr
                                                                          (cadr ls)))
                                                         (slide 2 args))
                                                    ") && (")
                                       "))"))
          (else (string-append "(" (string-join args opstr) ")")))))

(define (operator? s)
  (or (member s
              '(+ - * /)) 
      (cmp-op? s)))

(define (cmp-op? s)
  (member s
          '(< > <= >=)))

(define (single? ls)
  (and (not (null? ls))
       (null? (cdr ls))))

(define (slide n ls)
  (define (loop i ls acc)
    (cond ((null? ls) '())
          ((> i 1) (loop (- i 1) (cdr ls) (append acc (list (car ls)))))
          (else (let ((next (append acc (list (car ls)))))
                    (cons next
                          (loop 0 (cdr ls) (cdr next)))))))
  (loop n ls '())) 

ランタイム：

// Runtime library
function scmtrue(x) { return x; }

function cons(a, d) { var x = new Array(); x.car = a; x.cdr = d; return x; }
function car(x) { return x.car; }
function cdr(x) { return x.cdr; }
function consp(x) { return x && ((typeof x == "object") && (x.constructor == Array)); }
function nilp(x) { return x == null; }
function stringp(x) { return typeof(x) == "string"; }

function print(x) {
	_write_sub(x, false);
	_write_raw("\n");
	return undefined;
}

function write(x) {
	_write_sub(x, true);
	return undefined;
}

function _write_sub(x, bescape) {
	if (nilp(x)) {
		_write_raw("()");
	} else if (stringp(x)) {
		if (bescape) {
			_write_raw('"' + x + '"');
		} else {
			_write_raw(x);
		}
	} else if (consp(x)) {
		_write_cons(x, bescape);
	} else if (typeof(x) == "boolean") {
		if (x) {
			_write_raw("#t");
		} else {
			_write_raw("#f");
		}
	} else {
		_write_raw(x);
	}
}

function _write_cons(x, bescape) {
	var d;
	_write_raw("(");
	for (;;) {
		_write_sub(car(x), bescape);
		d = cdr(x);
		if (!consp(d)) {
			break;
		}
		x = d;
		_write_raw(" ");
	}
	if (!nilp(d)) {
		_write_raw(" . ");
		_write_sub(d, bescape);
	}
	_write_raw(")");
}

function list() {
	var ls = arguments;
	var n = ls.length;
	var r = null;
	for (var i=n; --i>=0; ) {
		r = cons(ls[i], r);
	}
	return r;
}

フォームから受け取って実行するところ：

var biwascheme = new BiwaScheme.Interpreter();
var codeElm = document.getElementById("scm2js");
var code = codeElm.textContent || codeElm.innerText || codeElm.text;
biwascheme.evaluate(code, function(result){});

function exec() {
	try {
		var form = document.inputbox;
		var str = form.code.value;
		str = "(string-join (map (lambda (s) (scm2js s '())) '(" + str + ")) \";\\n\")"

		biwascheme.evaluate(str, function(result){
			$('compileres').innerHTML = result;
			var r = eval(result);
			write(r);
			_write_raw("\n");
		});
	} catch(e) {
		alert(e);
	}
}

function _write_raw(x) {
	var out = document.logform.log;
	out.value += String(x);
	out.scrollTop = out.scrollHeight;  // scroll bottom
}

• Gauche上で作って、ブラウザで動かしたいのでBiwaSchemeに持ってきた。ほぼそのまま動いた、すげー。
• 一応環境を渡すようにしてるけど、スコープとかなにもしてない。JavaScriptに投げっぱなし。
• JavaScript上にシンボルの型を実装してないので、陽的には扱えない。あとシンボル名の変換あたりがうまく動いてないので、記号とか使えない（演算子は中置記法にするため別処理）。
• Gaucheでchar＜=?が２引数しか受け付けない。普通の比較演算子と同様に３つ以上渡せると便利だと思うんだけど。