ese-eval2 - begin (was 写経)

id:higepon:20070804:1186242639
id:higepon:20070807:1186498468
の続き。
native stack 使う版はすんなり理解できるがこれは難しいね。
begin の導入。begin は引数（という言いかたはあまり良くないが）を順に評価していき、最後の評価結果を返す。
最後の引数の評価を tail というオブジェクトにしてスタックに積むのミソか。
んー。まだちょっと消化しきれていないな。
tail ではなくて、invoke-proc で全ての引数を同様に need-sub-exp にした場合との違いとかが分からない。
両方の場合のスタックの動きをみたりとか、特殊形式 if あたりを実装すると分かるかも

ここ1-2ヶ月で一番ワクワクする内容だと思うのだけど、反響がなくてMさんと笑うという内幕も。
(追記)Scheme的にその書き方はないだろなどツッコミ歓迎。

(use util.list)
(use gauche.test)
(use util.queue)

(define (make-int i)
  `((type . int)
    (value .  ,i)))

(define (make-need-sub-exp exp)
  `((type . need-sub-exp)
    (sub . ,exp)))

(define (make-tail exp)
  `((type . tail)
    (sub . ,exp)))

(define (make-add  . args)
  `((type . symbol)
    (name . add)
    (args . ,args)))

(define (make-begin  . args)
  `((type . symbol)
    (name . begin)
    (args . ,args)))

(define (make-func cont)
  `((type . func)
    (cont . ,cont)))

(define (type-eq? exp type)
  (eq? (assq-ref exp 'type) type))

(define (int? exp)
  (type-eq? exp 'int))

(define (add? exp)
  (eq? (assq-ref exp 'name) 'add))

(define (begin? exp)
  (eq? (assq-ref exp 'name) 'begin))

(define (ese-symbol? exp)
  (type-eq? exp 'symbol))

(define (func? exp)
  (type-eq? exp 'func))

(define (need-sub-exp? exp)
  (type-eq? exp 'need-sub-exp))

(define (tail? exp)
  (type-eq? exp 'tail))

(define (dump-queue queue)
  '())

(define (make-flatten-cont row-args proc)
  (let ((arg-index 0) (args (make-vector (length row-args))))
    (lambda (func)
      (define (invoke-proc)
        (if (< arg-index (length row-args))
            (make-need-sub-exp (list-ref row-args arg-index))
            (make-int (proc (vector->list args)))))
      (define (resume retval)
        (vector-set! args arg-index retval)
        (set! arg-index (+ 1 arg-index)))
      (cond ((eq? func 'invoke-proc)
             invoke-proc)
            ((eq? func 'resume)
             resume)))))

(define (make-begin-cont row-args)
  (let ((arg-index 0))
    (lambda (func)
      (define (invoke-proc)
        (if (< arg-index (- (length row-args) 1))
            (make-need-sub-exp (list-ref row-args arg-index))
            (make-tail (list-ref row-args arg-index))))
      (define (resume retval)
        (set! arg-index (+ 1 arg-index)))
      (cond ((eq? func 'invoke-proc)
             invoke-proc)
            ((eq? func 'resume)
             resume)))))

(define (ese-eval exp)
  (let ((stack (make-queue)) (ret '()))
    (queue-push! stack exp)
    (let loop ((dummy (dump-queue stack)) (exp1 (queue-pop! stack)))
      (cond
       ((int? exp1)
        (if (not (queue-empty? stack))
            (((assq-ref (queue-front stack) 'cont) 'resume) (assq-ref exp1 'value))
            (set! ret (assq-ref exp1 'value))))
       ((and (ese-symbol? exp1) (add? exp1))
        (queue-push! stack (make-func (make-flatten-cont (assq-ref exp1 'args) (cut fold + 0 <>)))))
       ((and (ese-symbol? exp1) (begin? exp1))
        (queue-push! stack (make-func (make-begin-cont (assq-ref exp1 'args)))))
       ((func? exp1)
        (queue-push! stack exp1)
        (let ((res (((assq-ref exp1 'cont) 'invoke-proc))))
          (cond ((need-sub-exp? res) (queue-push! stack (assq-ref res 'sub)))
                ((int? res)
                 (queue-pop! stack)
                 (queue-push! stack res))
                ((tail? res)
                 (queue-pop! stack)
                 (queue-push! stack (assq-ref res 'sub)))
                (else (error "never reached here"))))))
      (if (zero? (queue-length stack))
          ret
          (loop (dump-queue stack) (queue-pop! stack))))))


(test-start "ese-eval")
(test* "eval int" 10 (ese-eval (make-int 10)))
(test* "(add 10 12)" 22 (ese-eval (make-add (make-int 10) (make-int 12))))
(test* "(add 10 12 13)" 35 (ese-eval (make-add (make-int 10) (make-int 12) (make-int 13))))
(test* "(add (add 1 3) 10)" 14 (ese-eval (make-add  (make-add (make-int 1) (make-int 3)) (make-int 10))))
(test* "(add (add 1 3) 10 (add 4 5))" 23 (ese-eval (make-add  (make-add (make-int 1) (make-int 3)) (make-int 10) (make-add (make-int 4) (make-int 5)))))
(test* "(begin 10 12 13)" 13 (ese-eval (make-begin (make-int 10) (make-int 12) (make-int 13))))
(test* "(begin 10 12 (+ 1 3))" 4 (ese-eval (make-begin (make-int 10) (make-int 12) (make-add (make-int 1) (make-int 3)))))
(test-end)