`(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) がアナフォリックマクロ的に使えて便利だなと思う今日この頃。
  • 続きを読む

2008-12-10

バッククォート式の効率的な展開

自分で考えてもさっぱりわからないので Gaucheのソースを見る。該当ソースは compile.scm の (define-pass1-syntax (quasiquote form cenv) ...) あたり。util.match を使っていろいろ変形してるっぽい。compile.scm を動かそうとしたんだけど eval-when とか使っててそのままだと動かせなかったので、切り貼りしてみた。

(use util.match)

(define-constant $CONST '$CONST)
(define-constant $CONS '$CONS)
(define-constant $LIST '$LIST)
(define-constant $LIST* '$LIST*)
(define-constant $GREF '$GREF)
(define-constant $APPEND '$APPEND)

(define ($const x) (vector $CONST x))
(define ($gref x)  (vector $GREF x))
(define $const-nil (let1 x ($const '()) (lambda () x)))
(define ($append src arg0 arg1) (vector $APPEND src arg0 arg1))
(define ($list src args) (vector $LIST src args))
(define ($list* src args) (vector $LIST* src args))
(define ($const-value x) (vector-ref x 1))

;; quasiquote tends to generate nested $cons, which can be
;; packed to $list or $list*.
(define ($cons o x y)
  (if (has-tag? y $CONS)
    (receive (type elts) ($cons-pack y)
      (vector type o (cons x elts)))
    (vector $CONS o x y)))

(define ($cons-pack elt)
  (cond
   ((equal? elt ($const-nil)) (values $LIST '()))
   ((has-tag? elt $CONS)
    (receive (type elts) ($cons-pack (vector-ref elt 3))
      (values type (cons (vector-ref elt 2) elts))))
   (else (values $LIST* (list elt)))))


;; check intermediate tag
(define-macro (has-tag? iform tag)
  `(eqv? (vector-ref ,iform 0) ,tag))

(define (pass1 program cenv)
  (cond ((pair? program)
         (case (car program)
           ((quasiquote) (syntax/quasiquote program cenv))
           (else ($const program))))
        ((symbol? program)
         ($gref program))
        (else
         ($const program))))

;; Quote and quasiquote ................................

(define (syntax/quasiquote form cenv)
  ;; We want to avoid unnecessary allocation as much as possible.
  ;; Current code generates constants not only the obvious constant
  ;; case, e.g. `(a b c), but also folds constant variable references,
  ;; e.g. (define-constant x 3) then `(,x) generate a constant list '(3).
  ;; This extends as far as the constant folding goes, so `(,(+ x 1)) also
  ;; becomes '(4).

  ;; The internal functions returns two values, of which the first value
  ;; indicates whether the subtree is constant or not.   The second value
  ;; is a constant object (if the subtree is constant), or an IForm (if
  ;; the subtree is non-constant).

  (define (wrap const? tree)
    (if const? ($const tree) tree))

  (define (quasi obj level)
    (match obj
      (('quasiquote x)
       (receive (c? r) (quasi x (+ level 1))
         (if c?
           (values #t (list 'quasiquote r))
           (values #f ($list obj (list ($const 'quasiquote) r))))))
      (('unquote x)
       (if (zero? level)
         (let1 r (pass1 x cenv)
           (if (has-tag? r $CONST)
             (values #t ($const-value r))
             (values #f r)))
         (receive (xc? xx) (quasi x (- level 1))
           (if xc?
             (values #t (list 'unquote xx))
             (values #f ($list obj (list ($const 'unquote) xx)))))))
      ((x 'unquote-splicing y)            ;; `(x . ,@y)
       (if (zero? level)
         (error "unquote-splicing appeared in invalid context:" obj)
         (receive (xc? xx) (quasi x level)
           (receive (yc? yy) (quasi y level)
             (if (and xc? yc?)
               (values #t (list xx 'unquote-splicing yy))
               (values #f ($list obj (list xx ($const 'unquote-splicing) yy))))))))
      ((('unquote-splicing x))            ;; `(,@x)
       (if (zero? level)
         (let1 r (pass1 x cenv)
           (if (has-tag? r $CONST)
             (values #t ($const-value r))
             (values #f r)))
         (receive (xc? xx) (quasi x (- level 1))
           (if xc?
             (values #t (list (list 'unquote-splicing xx)))
             (values #f ($list obj
                               (list ($list (car obj)
                                            (list ($const 'unquote-splicing)
                                                  xx)))))))))
      ((('unquote-splicing x) . y)        ;; `(,@x . rest)
       (receive (yc? yy) (quasi y level)
         (if (zero? level)
           (let1 r (pass1 x cenv)
             (if (and yc? (has-tag? r $CONST))
               (values #t (append ($const-value r) yy))
               (values #f ($append obj r (wrap yc? yy)))))
           (receive (xc? xx) (quasi x (- level 1))
             (if (and xc? yc?)
               (values #t (cons (list 'unquote-splicing xx) yy))
               (values #f ($cons obj
                                 ($list (car obj)
                                        (list ($const 'unquote-splicing)
                                              (wrap xc? xx)))
                                 (wrap yc? yy))))))))
      ((x 'unquote y)                     ;; `(x . ,y)
       (receive (xc? xx) (quasi x level)
         (if (zero? level)
           (let1 r (pass1 y cenv)
             (if (and xc? (has-tag? r $CONST))
               (values #t (cons xx ($const-value r)))
               (values #f ($cons obj (wrap xc? xx) r))))
           (receive (yc? yy) (quasi y level)
             (if (and xc? yc?)
               (values #t (list xx 'unquote yy))
               (values #f ($list obj (list (wrap xc? xx)
                                           ($const 'unquote)
                                           (wrap yc? yy)))))))))
      ((x . y)                            ;; general case of pair
       (receive (xc? xx) (quasi x level)
         (receive (yc? yy) (quasi y level)
           (if (and xc? yc?)
             (values #t (cons xx yy))
             (values #f ($cons obj (wrap xc? xx) (wrap yc? yy)))))))
      ((? vector?) (quasi-vector obj level))
      ((? identifier?)
       (values #t (slot-ref obj 'name))) ;; unwrap syntax
      (else
       (values #t obj))))

  (define (quasi-vector obj level)
    (if (vector-has-splicing? obj)
      (receive (c? r) (quasi (vector->list obj) level)
        (values #f ($list->vector obj (wrap c? r))))
      (let* ((need-construct? #f)
             (elts (map (lambda (elt)
                          (receive (c? tree) (quasi elt level)
                            (if c?
                              ($const tree)
                              (begin
                                (set! need-construct? #t)
                                tree))))
                        (vector->list obj))))
        (if need-construct?
          (values #f ($vector obj elts))
          (values #t (list->vector (map (lambda (e) ($const-value e)) elts))))
        )))

  (define (vector-has-splicing? obj)
    (let loop ((i 0))
      (cond ((= i (vector-length obj)) #f)
            ((and (pair? (vector-ref obj i))
                  (eq? (car (vector-ref obj i)) 'unquote-splicing))
             #t)
            (else (loop (+ i 1))))))
  
  (match form
    ((_ obj)
     (receive (c? r) (quasi obj 0)
       (wrap c? r)))
    (else (error "syntax-error: malformed quasiquote:" form)))
  )

;;;;;;;;

(define (transform-quasiquote s)
  (define (expand iform)
    (case (vector-ref iform 0)
      (($CONST)  (list 'quote (vector-ref iform 1)))
      (($GREF)   (vector-ref iform 1))
      (($CONS)   (let ((a (expand (vector-ref iform 2)))
                       (d (expand (vector-ref iform 3))))
                   `(cons ,a ,d)))
      (($LIST)   `(list ,@(map expand (vector-ref iform 2))))
      (($LIST*)  `(list* ,@(map expand (vector-ref iform 2))))
      (($APPEND) `(append ,(expand (vector-ref iform 2)) ,(expand (vector-ref iform 3))))
      (else `("???" ,iform))))
  (expand (syntax/quasiquote s '())))

テスト:

gosh> (transform-quasiquote '`x)
'x
gosh> (transform-quasiquote '`,x)
x
gosh> (transform-quasiquote '`(,x))
(cons x '())
gosh> (transform-quasiquote '`(1 2 ,@x 3))
(list* '1 '2 (append x '(3)))
gosh> (transform-quasiquote '`(defmacro ,short (&rest args) `(,',long ,@args)))
(list* 'defmacro short (list '(&rest args) (list 'quasiquote (cons (list 'unquote (list 'quote long)) '(,@args)))))

む~むずい。

  • 多重のバッククォートも一気に展開してるぽい
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20081210

2008-12-06

plan

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

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上にシンボルの型を実装してないので、陽的には扱えない。あとシンボル名の変換あたりがうまく動いてないので、記号とか使えない(演算子は中置記法にするため別処理)。
  • Gauchechar<=?が2引数しか受け付けない。普通の比較演算子と同様に3つ以上渡せると便利だと思うんだけど。
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20081206

2008-12-03

S式リーダ

実装のソースを読む

xyzzy のリーダ
  • ソース:lread.cc
  • 設定してるところ:static void default_readtable ()
  • すべてリーダーマクロになってる
  SET_TERM_MACRO (r, '"', double_quote_reader);
  SET_TERM_MACRO (r, '\'', single_quote_reader);
  SET_TERM_MACRO (r, '(', open_paren_reader);
  SET_TERM_MACRO (r, ')', close_paren_reader);
  SET_TERM_MACRO (r, ',', comma_reader);
  SET_TERM_MACRO (r, ';', semicolon_reader);
  SET_TERM_MACRO (r, '`', backquote_reader);
  SET_NONTERM_MACRO (r, '#', dispmacro_reader);
  SET_DISP_MACRO (d, '\\', number_backslash_reader);
  SET_DISP_MACRO (d, '\'', number_single_quote_reader);
  SET_DISP_MACRO (d, '(', number_open_paren_reader);
  SET_DISP_MACRO (d, ':', number_colon_reader);
  SET_DISP_MACRO (d, '.', number_dot_reader);
  SET_DISP_MACRO (d, 'B', number_B_reader);
  SET_DISP_MACRO (d, 'O', number_O_reader);
  SET_DISP_MACRO (d, 'X', number_X_reader);
  SET_DISP_MACRO (d, 'R', number_R_reader);
  SET_DISP_MACRO (d, 'S', number_S_reader);
  SET_DISP_MACRO (d, 'C', number_C_reader);
  SET_DISP_MACRO (d, 'A', number_A_reader);
  SET_DISP_MACRO (d, '=', number_equal_reader);
  SET_DISP_MACRO (d, '#', number_number_reader);
  SET_DISP_MACRO (d, '+', number_plus_reader);
  SET_DISP_MACRO (d, '-', number_minus_reader);
  SET_DISP_MACRO (d, '|', number_bar_reader);
    • 例:semicolon_reader
static lisp
semicolon_reader (lisp stream, Char)
{
  lChar c;
  do
    c = readc_stream (stream);
  while (c != '\n' && c != lChar_EOF);
  return 0;
}
  • 実際にS式を読み込むところ:static lisp lisp_parser() <- parser() から呼び出される
    • マクロの読み込み:macro_reader()
      • Cの関数かLispの関数の呼び出し
  • リーダーの設定:Lisp側=set-macro-character、C側=Fset_macro_character
    • 呼び出された場合は、Cの関数が get_reader_macro_function になる

細かい動作は追ってない。

Commn Lisp
Gaucheのリーダ
  • ソース:src/read.c
  • S式を1つ読み込み:static ScmObj read_internal()
  • 全部 switch case で書いてある
  • リーダーマクロはない
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20081203