2008-12-06
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<=?が2引数しか受け付けない。普通の比較演算子と同様に3つ以上渡せると便利だと思うんだけど。
コメント
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20081206