`(Hello ,world)

ツッコミ、添削大歓迎です。いろいろ教えてください。

2008-12-15

BiwaSchemeにいくつか要望

あつかましさついでにいくつか要望をば…

  • eval が文字列を受け付けるようになっている => S式を渡したい
  • read-from-string が欲しい
  • "" が #<undef> になる
    • 内部的には文字列だけど、表示用の文字列への変換時に undefined 判定されて #<undef> になってるぽい

BiwaSchemeに任意長引数を追加したい

BiwaSchemeで任意長の引数を扱えなかったのだけど、define-macro追加のためにどうしても欲しかったので、stackbase.jsに手を加えてみました。よかったら反映していただけるとありがたいです。一応 spec.html を走らせてテストはパスすることは確認しました。以下、diffです:

*** stackbase.org.js	Mon Dec 15 20:26:56 2008
--- stackbase.js	Mon Dec 15 21:57:11 2008
***************
*** 639,644 ****
--- 639,645 ----
        switch(this.value){
          case '\n': return "#\\newline";
          case ' ':  return "#\\space";
+         case '\t': return "#\\tab";
          default:   return "#\\"+this.value;
        }
      },
***************
*** 818,823 ****
--- 819,826 ----
            return Char.get('\n');
          } else if( t.toLowerCase() == '#\\space' ) {
            return Char.get(' ');
+         } else if( t.toLowerCase() == '#\\tab' ) {
+           return Char.get('\t');
          } else if( /^#\\.$/.test(t) ) {
            return Char.get( t.charAt(2) );
          } else if( /^\"(\\(.|$)|[^\"\\])*\"?$/.test(t) ) {
***************
*** 1035,1040 ****
--- 1038,1096 ----
          return ret;
      },
  
+     find_dot_pos: function(x){
+       var idx = 0;
+       for (; x instanceof Pair && x != nil; x = x.cdr, ++idx)
+         ;
+       if (x != nil) {
+         return idx;
+       } else {
+         return -1;
+       }
+     },
+ 
+     last_pair: function(x){
+       if (x instanceof Pair && x != nil){
+         for (; x.cdr instanceof Pair && x.cdr != nil; x = x.cdr)
+           ;
+       }
+       return x;
+     },
+ 
+     // dotted list -> proper list
+     dotted2proper: function(ls){
+       var nreverse = function(ls){
+         var res = nil;
+         for (; ls instanceof Pair && ls != nil; ){
+           var d = ls.cdr;
+           ls.cdr = res;
+           res = ls;
+           ls = d;
+         }
+         return res;
+       }
+       var copy_list = function(ls){
+         var res = nil;
+         for (; ls instanceof Pair && ls != nil; ls = ls.cdr){
+           res = new Pair(ls.car, res);
+         }
+         return nreverse(res);
+       }
+ 
+       if (ls instanceof Pair) {
+         var last = this.last_pair(ls);
+         if (last instanceof Pair && last.cdr == nil){
+           return ls;
+         } else {
+           var copied = copy_list(ls);
+           this.last_pair(copied).cdr = new Pair(last.cdr, nil);
+           return copied;
+         }
+       } else {
+         return new Pair(ls, nil);
+       }
+     },
+ 
      // x: exp(list of symbol or integer or..)
      // e: env (= [locals, frees])
      // s: vars might be set!
***************
*** 1093,1110 ****
              var vars = x.cdr.car;
              var body = new Pair(Sym("begin"), x.cdr.cdr); //tenuki
  
!             var free = this.find_free(body, vars.to_set(), f); //free variables
!             var sets = this.find_sets(body, vars.to_set()); //local variables
  
              var do_body = this.compile(body,
!                             [vars.to_set(), free],
                              sets.set_union(s.set_intersect(free)),
!                             f.set_union(vars.to_set()),
!                             ["return", vars.length()]);
              var do_close = ["close", 
                               free.size(),
!                              this.make_boxes(sets, vars, do_body),
!                              next];
              return this.collect_free(free, e, do_close);
            case Sym("if"):
              var testc=x.second(), thenc=x.third(), elsec=x.fourth();
--- 1149,1169 ----
              var vars = x.cdr.car;
              var body = new Pair(Sym("begin"), x.cdr.cdr); //tenuki
  
!             var dotpos = this.find_dot_pos(vars);
!             var proper = this.dotted2proper(vars);
!             var free = this.find_free(body, proper.to_set(), f); //free variables
!             var sets = this.find_sets(body, proper.to_set()); //local variables
  
              var do_body = this.compile(body,
!                             [proper.to_set(), free],
                              sets.set_union(s.set_intersect(free)),
!                             f.set_union(proper.to_set()),
!                             ["return"]);
              var do_close = ["close", 
                               free.size(),
!                              this.make_boxes(sets, proper, do_body),
!                              next,
!                              dotpos];
              return this.collect_free(free, e, do_close);
            case Sym("if"):
              var testc=x.second(), thenc=x.third(), elsec=x.fourth();
***************
*** 1126,1134 ****
              var c = ["conti", 
                        (this.is_tail(next) ? next[1] : 0), //number of args for outer lambda
                        ["argument",
                          this.compile(x, e, s,f,  
!                           (this.is_tail(next) ? ["shift", 1, next[1], ["apply", 1]]
!                                               : ["apply", 1]))]];
                      //note: proc for call/cc takes 1 argument (= ["apply", 1])
              return this.is_tail(next) ? c : ["frame", c, next];
            default: 
--- 1185,1195 ----
              var c = ["conti", 
                        (this.is_tail(next) ? next[1] : 0), //number of args for outer lambda
                        ["argument",
+                       ["constant", 1,
+                       ["argument",
                          this.compile(x, e, s,f,  
!                           (this.is_tail(next) ? ["shift", 1, ["apply"]]
!                                               : ["apply"]))]]]];
                      //note: proc for call/cc takes 1 argument (= ["apply", 1])
              return this.is_tail(next) ? c : ["frame", c, next];
            default: 
***************
*** 1139,1146 ****
              var func = x.car;
              var args = x.cdr;
              var c = this.compile(func, e, s,f,  
!                       this.is_tail(next) ? ["shift", args.length(), next[1], ["apply", args.length()]]
!                                          : ["apply", args.length()]);
              for(var p=args; p instanceof Pair && p!=nil; p=p.cdr){
                c = this.compile(p.car, e, s, f, ["argument", c]);
              }
--- 1200,1208 ----
              var func = x.car;
              var args = x.cdr;
              var c = this.compile(func, e, s,f,  
!                       this.is_tail(next) ? ["shift", args.length(), ["apply"]]
!                                          : ["apply"]);
!             c = this.compile(args.length(), e, s, f, ["argument", c]);  // 引数の数をスタックに積む
              for(var p=args; p instanceof Pair && p!=nil; p=p.cdr){
                c = this.compile(p.car, e, s, f, ["argument", c]);
              }
***************
*** 1248,1258 ****
      //ret: closure array
      continuation: function(s, n){
        // note: implementation of this function for final version doesn't exist in 3imp.pdf..
        return this.closure(["refer-local", 0,
!                             ["nuate", this.save_stack(s), 
!                             ["return", n]]], 
                            0,     //n (number of frees)
!                           null); //s (stack position to get frees)
      },
  
      // shift stack 
--- 1310,1322 ----
      //ret: closure array
      continuation: function(s, n){
        // note: implementation of this function for final version doesn't exist in 3imp.pdf..
+       var ss = this.push(n, s);
        return this.closure(["refer-local", 0,
!                             ["nuate", this.save_stack(ss), 
!                             ["return"]]], 
                            0,     //n (number of frees)
!                           null,  //s (stack position to get frees)
!                           -1);   // dotpos
      },
  
      // shift stack 
***************
*** 1260,1285 ****
      // m: number of items to shift
      // s: stack pointer (= index of stack top + 1)
      shift_args: function(n, m, s){
!       for(var i = n-1; i >= 0; i--){
!         this.index_set(s, i+m, this.index(s, i));
        }
!       return s-m;
      },
  
      index: function(s, i){
!       return this.stack[s-i-1];
      },
  
      index_set: function(s, i, v){
!       this.stack[s-i-1] = v;
      },
  
!     //ret: [body, stack[s-1], stack[s-2], ..]
!     closure: function(body, n, s){
!       var v = []; //(make-vector n+1)
        v[0] = body;
        for(var i=0; i<n; i++)
!         v[i+1] = this.index(s, i);
        return v;
      },
  
--- 1324,1350 ----
      // m: number of items to shift
      // s: stack pointer (= index of stack top + 1)
      shift_args: function(n, m, s){
!       for(var i = n-1; i >= -1; i--){
!         this.index_set(s, i+m+1, this.index(s, i));
        }
!       return s-m-1;
      },
  
      index: function(s, i){
!       return this.stack[s-i-2];
      },
  
      index_set: function(s, i, v){
!       this.stack[s-i-2] = v;
      },
  
!     //ret: [body, stack[s-1], stack[s-2], .., stack[s-n], dotpos]
!     closure: function(body, n, s, dotpos){
!       var v = []; //(make-vector n+1+1)
        v[0] = body;
        for(var i=0; i<n; i++)
!         v[i+1] = this.index(s, i-1);
!       v[n+1] = dotpos;
        return v;
      },
  
***************
*** 1328,1335 ****
            a = obj;
            break;
          case "close":
!           var n=x[1], body=x[2], x=x[3];
!           a = this.closure(body, n, s);
            s -= n;
            break;
          case "box":
--- 1393,1401 ----
            a = obj;
            break;
          case "close":
!           var ox=x;
!           var n=ox[1], body=ox[2], x=ox[3], dotpos=ox[4];
!           a = this.closure(body, n, s, dotpos);
            s -= n;
            break;
          case "box":
***************
*** 1376,1389 ****
            s = this.push(a, s);
            break;
          case "shift":
!           var n=x[1], m=x[2], x=x[3];
!           s = this.shift_args(n, m, s);
            break;
          case "apply": //extended: n_args as second argument
!           var func = a, n_args = x[1];
            if(func instanceof Array){ //closure
              a = func;
              x = func[0];
              f = s;
              c = a;
            }
--- 1442,1473 ----
            s = this.push(a, s);
            break;
          case "shift":
!           var n=x[1], x=x[2];
!           var n_args = this.index(s, n);  // 一つ前の呼び出しの引数の数
!           s = this.shift_args(n, n_args, s);
            break;
          case "apply": //extended: n_args as second argument
!           var func = a; //, n_args = x[1];
!           var n_args = this.index(s, -1);  // 直前に引数の数を積んである
            if(func instanceof Array){ //closure
              a = func;
              x = func[0];
+             var dotpos = func[func.length-1];  // 仮引数のドットの位置
+             if (dotpos >= 0) {  // 任意個の引数を処理
+               var ls = nil;
+               for (var i=n_args; --i>=dotpos; ) {
+                 ls = new Pair(this.index(s, i), ls);
+               }
+               if (dotpos >= n_args) {
+                 // rest 用の領域がない:スタックをずらす
+                 for(var i = -1; i < n; i++){
+                   this.index_set(s, i-1, this.index(s, i));
+                 }
+                 s++;
+                 this.index_set(s, -1, this.index(s, -1) + 1);  // 引数の数を増やす
+               }
+               this.index_set(s, dotpos, ls);
+             }
              f = s;
              c = a;
            }
***************
*** 1396,1402 ****
  
              if(result instanceof Pause){
                var pause = result;
!               pause.set_state(this, ["return", n_args], f, c, s);
                pause.ready();
                return pause;
              }
--- 1480,1486 ----
  
              if(result instanceof Pause){
                var pause = result;
!               pause.set_state(this, ["return"], f, c, s);
                pause.ready();
                return pause;
              }
***************
*** 1411,1421 ****
                //   x
                var call_after = ["frame",
                                   ["argument",
                                   ["constant", result.after,
!                                  ["apply", 1]]],
!                                ["return", n_args]];
!               var call_proc = ["constant", result.proc, 
!                               ["apply", result.args.length]];
                var push_args = result.args.inject(call_proc, function(opc, arg){
                  // (foo 1 2) => first push 2, then 1
                  //   [constant 2 ... [constant 1 ... ]
--- 1495,1509 ----
                //   x
                var call_after = ["frame",
                                   ["argument",
+                                  ["constant", 1,
+                                  ["argument",
                                   ["constant", result.after,
!                                  ["apply"]]]]],
!                                ["return"]];
!               var call_proc = ["constant", result.args.length,
!                               ["argument",
!                               ["constant", result.proc, 
!                               ["apply", result.args.length]]]];
                var push_args = result.args.inject(call_proc, function(opc, arg){
                  // (foo 1 2) => first push 2, then 1
                  //   [constant 2 ... [constant 1 ... ]
***************
*** 1429,1435 ****
              }
              else{
                a = result;
!               x = ["return", n_args];
              }
            }
            else{
--- 1517,1523 ----
              }
              else{
                a = result;
!               x = ["return"];
              }
            }
            else{
***************
*** 1437,1448 ****
            }
            break;
          case "return":
!           var n=x[1];
!           var ss=s-n; 
            x = this.index(ss, 0),
            f = this.index(ss, 1),
            c = this.index(ss, 2),
!           s = ss-3;
            break;
          default:
            throw new Bug("unknown opecode type: "+x[0]);
--- 1525,1536 ----
            }
            break;
          case "return":
!           var n=this.index(s, -1);
!           var ss=s-n;
            x = this.index(ss, 0),
            f = this.index(ss, 1),
            c = this.index(ss, 2),
!           s = ss-3-1;
            break;
          default:
            throw new Bug("unknown opecode type: "+x[0]);
***************
*** 1585,1591 ****
        args || (args = []);
        var n_args  = args.length;
  
!       var x = ["constant", closure, ["apply", n_args]]
        for(var i=0; i<n_args; i++)
          x = ["constant", args[i], ["argument", x]]
  
--- 1673,1679 ----
        args || (args = []);
        var n_args  = args.length;
  
!       var x = ["constant", n_args, ["argument", ["constant", closure, ["apply"]]]]
        for(var i=0; i<n_args; i++)
          x = ["constant", args[i], ["argument", x]]
  

修正した内容は:

  • lambda の仮引数リストがドットリストだったらその位置を記録、なければ -1
    • フリー変数、セットされる変数の列挙時にその変数も考慮に入れる
  • 手続き呼び出し時に呼び出されたクロージャ側で与えられた引数の数を知りたいので、引数の数をスタックの一番最後に積むように変更
    • それにともなって、スタックの参照を変更
  • 呼び出された手続きが任意個の引数を取る手続きだったら、残りの引数をリストにしてスタック上のローカル変数の値を変更する
    • スペースがない可能性があるので、その場合はスタックをずらす
  • 手続きへの引数の数はスタックに積んであるので、return, apply, shift のパラメータを削除
  • continuation 作成時に、return用に外のlambdaの引数をスタックに積むように変更

define-macro追加

Sheme->JSコンパイラの続き。yharaさんにstring->listを直していただいたので、null?とかeq?とかSchemeっぽい関数をいくつか追加。

letとかcondとかさせたかったのでスペシャルフォームにdefine-macroを追加した。デモは同じところ

  • (cond ((pred) => action) がアナフォリックマクロ的に使えて便利だなと思う今日この頃。
;;;; Scheme -> JavaScript compiler

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

(define (compile-literal s)
  (cond ((string? s) (string-append "\"" (escape-string s) "\""))
        ((symbol? s) (string-append "SCM.intern(\"" (escape-string (symbol->string s)) "\")"))
        ((number? s) (number->string s))
        ((null? s)   "null")
        ((eq? s #t)  "true")
        ((eq? s #f)  "false")
        ((char? s)   (string-append "SCM._gen_char(\"" (escape-string (string s)) "\")"))
        (else (error "compile-literal"))))

(define (escape-string s)
  (define (escape c)
    (case c
      ((#\\)       "\\\\")
      ((#\tab)     "\\t")
      ((#\newline) "\\n")
      ((#\")       "\\\"")
      (else (string c))))
  (apply string-append (map escape (string->list s))))

(define (ref-env sym env)
  (if (local-var? sym env)
      (scm->js-symbol sym)
    (string-append "SCM." (scm->js-symbol sym))))

(define (local-var? sym env)
  (member sym env))

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

(define (js-sym-char? c)
  (alnum? c))

(define (integer->hex-string x keta)
  (let* ((s (number->string x 16))
         (l (string-length s)))
    (if (< l keta) ;>
        (let1 zeros (make-string (- keta l) #\0)
          (string-append zeros s))
      s)))

(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)
      (compile-literal x))))

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

(define (extend-env env parm)
  (append parm env))

(define (expand-body body env)
  (cond ((null? body) "")
        ((single? 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 (compile-if s env)
  (let ((p (cadr s))
        (th (caddr s))
        (el (cdddr s)))
    (string-append "(SCM._true("
                   (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-set! s env)
  (let ((name (cadr s))
        (val (caddr s)))
    (string-append (scm2js name env)
                   " = "
                   (scm2js val env))))

(define (compile-js-statement s env)
  (cadr s))

;;; ==== macro ====
(define *macros* '())

(define (compile-define-macro s env)
  (let* ((parms (cadr s))
         (body  (cddr s))
         (name (car parms))
         (args (cdr parms))
         (fn (eval `(lambda ,args ,@body) (interaction-environment))))
;         (fn (eval (tostring `(lambda ,args ,@body)))))
    (cond ((assoc name *macros*) => (lambda (m) (set-cdr! m fn)))
          (else (set! *macros* (cons (cons name fn)
                                     *macros*))))
    (string-append "/* "
                   (symbol->string name)
                   " */")))

(define (macro? s)
  (cond ((assoc (car s) *macros*) => cdr)
        (else #f)))

(define (expand-macro m s)
  (apply m (cdr s)))  ; Throw to backend scheme.
;;; ==== macro ====

(define *special-forms*
  `((quote        . ,compile-quote)
    (lambda       . ,compile-lambda)
    (if           . ,compile-if)
    (define       . ,compile-define)
    (set!         . ,compile-set!)
    (define-macro . ,compile-define-macro)
    (js-statement . ,compile-js-statement)
    ))

(define (special-form? s)
  (cond ((assoc (car s) *special-forms*) => cdr)
        (else #f)))

(define (compile-funcall s env)
  (let ((fn (car s))
        (args (cdr s)))
    (if (operator? fn)
        (prefix->infix fn args env)
      (string-append (scm2js fn env)
                     "("
                     (expand-args args 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)
           (let ((cmp-op1 (lambda (ls)
                            (string-append (car ls)
                                           opstr
                                           (cadr ls)))))
             (string-append "(("
                            (string-join (map cmp-op1 (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
          '(< > <= >=)))

;;;; Utility

(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 '()))

(define (alnum? c)
  (or (alpha? c) (num? c)))

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

(define (num? c)
  (and (char<=? #\0 c) (char<=? c #\9))) ;>

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

;;; x->string
(define (tostring x)
  (cond ((null? x) "()")
        ((eq? x #t) "#t")
        ((eq? x #f) "#f")
        ((symbol? x) (symbol->string x))
        ((string? x) x)
        ((number? x) (number->string x))
        ((pair? x) (cons->string x))
        (else (error "illegal type"))))

(define (cons->string x)
  (define (loop x)
    (cond ((null? x) x)
          ((pair? x) (cons (tostring (car x))
                           (loop (cdr x))))
          (else
           (list (string-append ". "
                                (tostring x))))))
  (string-append "("
                 (string-join (loop x) " ")
                 ")"))


;;;; macro definition
(scm2js '(define-macro (begin . body)
           (cond ((null? body) #f)
                 ((single? body) (car body))
                 (else `((lambda () ,@body)))))
        '())

(scm2js '(define-macro (let args . body)
           `((lambda ,(map car args)
               ,@body)
             ,@(map cadr args)))
        '())

(scm2js '(define-macro (let1 var val . body)
           `(let ((,var ,val))
              ,@body))
        '())

(scm2js '(define-macro (let* args . body)
           (if (null? args)
               `(begin ,@body)
             `(let (,(car args))
                (let* ,(cdr args) ,@body))))
        '())

(scm2js '(define-macro (cond . args)
           (if (null? args)
               #f
             (let* ((clause (car args))
                    (pred (car clause))
                    (body (cdr clause)))
               (if (pair? pred)
                   (if (and (not (null? body))
                            (eq? (car body) '=>))
                       `(let1 it ,pred
                          (if it
                              (,(cadr body) it)
                            (cond ,@(cdr args))))
                     `(if ,pred (begin ,@body)
                        (cond ,@(cdr args))))
                 `(begin ,@body)))))  ; else clause
        '())

(scm2js '(define-macro (case val . args)
           (if (null? args)
               #f
             (let* ((clause (car args))
                    (pred (car clause))
                    (body (cdr clause)))
               (if (pair? pred)
                   `(if ,(if (null? (cdr pred))
                             `(eq? ,val ',(car pred))
                           `(member ,val ',pred))
                        (begin ,@body)
                      (case ,val ,@(cdr args)))
                 `(begin ,@body)))))  ; else clause
        '())

(scm2js '(define-macro (and . args)
           (cond ((null? args) #t)
                 ((null? (cdr args)) (car args))
                 (else
                  `(if ,(car args)
                       (and ,@(cdr args))
                     #f))))
        '())
  • コンパイルした結果の、実行時のconsなどのデータ構造も全面的にBiwaSchemeに頼るようにした。表示とかが自動的に読みやすい形にしてくれるので便利。