naga:ecevalでcall > cc

naga
eceval に call/cc の実装を試みた。一応それらしくは動作している。

変更概要
1. 脱出(esc)手続きを ('esc esc-proc) の形式で導入する。
eceval では register は後で必要と判断した個所で stack に save する方針なので
call/cc では register の退避は行わない。
2. call/cc の脱出手続き引数として call/cc の引数の手続きを実行する処理のやり易さ
を考えて、call/cc を special form とする。
3. esc-proc は primitive として実行する。
esc-proc の実体は make-esc にあるように call/cc 実行時に save したスタックの
resotre の復元。

;;; eceval の変更
;;;  eval-dispatch に call/cc と esc の 判定を追加。
       (test (op call/cc?) (reg exp))
       (branch (label ev-call/cc))
;;;  apply-dispatch に esc 手続きの処理判定追加。
     apply-dispatch
       (test (op primitive-procedure?) (reg proc))
       (branch (label primitive-apply))
       (test (op compound-procedure?) (reg proc))
       (branch (label compound-apply))
       (test (op esc?) (reg proc))      ; call/cc
       (branch (label primitive-apply)) ; call/cc
       (goto (label unknown-procedure-type))
;;;  ev-call/cc の追加
     ev-call/cc
       (save continue)                  ; call/cc の継続を スタックに save して
       (assign unev (op make-esc))      ; esc 手続きを作成（スタックをsave）
       (restore continue)
                                        ; call/cc で指定された手続きを ecs 手続きを
                                        ; 引数にして eval-dispatch に引き渡す（実行）
       (assign proc (op call/cc-proc) (reg exp))
       (assign exp (op call/cc-proc-exp) (reg proc) (reg unev))
       (goto (label eval-dispatch))

;;; eceval-operations の追加
;;; self には実行中の machine の dispatch が設定されている。
(define (call/cc? exp) (tagged-list? exp 'call/cc))
(define (esc? exp) (tagged-list? exp 'esc))
(define (call/cc-proc exp) (cadr exp))
(define (make-esc)
  (let* ((sv-stack (save-stack))
         (esc-proc (lambda (v)          ; esc 手続きの実体。primitive として実行。
                     (restore-stack sv-stack)
                     v)))
    (list 'quote (list 'esc esc-proc))  ; esc 手続き(call/cc 引数の手続きの引数に
                                        ; bind するため１回 quote する。)
    ))
(define (call/cc-proc-exp proc esc) (list proc esc))

;;; Register-Machine Simulator の変更
;;;  stack の save/restore 機能の追加
;;;  手続き make-stack に 内部定義手続き save と restore を追加。内部手続き dispatch
;;;  の変更
    (define (save)
      (list s number-pushes max-depth))
    (define (restore stack-env)
      (set! s (car stack-env))
      (set! number-pushes (cadr stack-env))
      (set! max-depth (caddr stack-env)))
    (define (dispatch message)
      (cond ((eq? message 'push) push)
            ((eq? message 'pop) (pop))
            ((eq? message 'initialize) (initialize))
            ((eq? message 'print-statistics) (print-statistics))
            ((eq? message 'save) (save))     ; call/cc
            ((eq? message 'restore) restore) ; call/cc
            (else (error "Unknown request -- STACK" message))))
;;;  save/restore の呼出し手続き
(define (save-stack)
  ((self 'stack) 'save))
(define (restore-stack save-stack-env)
  (((self 'stack) 'restore) save-stack-env))

;;;実行例
;;; EC-Eval input:
(define retry #f)
(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(define (n! n)
  (if (= n 1)
      (call/cc (lambda (k) (set! retry k) 1))
      (* n (n! (- n 1)))))
(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(n! 3)
(total-pushes = 71 maximum-depth = 14)
;;; EC-Eval value:
6
;;; EC-Eval input:
(retry 2)
(total-pushes = 61 maximum-depth = 14)
;;; EC-Eval value:
12
;;; EC-Eval input:
(retry 3)
(total-pushes = 61 maximum-depth = 14)
;;; EC-Eval value:
18