ese-eval (was 写経)

処理系の基礎を学ぼうぜ的な ese-eval 講座 by Mさん。
ノートにスタックを書きながら Scheme （Gauche）で書いてる。

• 一般化らしい
• 引数の扱いが make-flatten-cont あたり。
• add は可変引数に対応している。

短いけど頭が混乱するな。
だいぶ難しくなってきましたよ。＞ Mさん

個人的には↓の部分で cut と fold が自然に頭に浮かんだのが成長を感じさせる（そこかよ

((add? exp1)
  (queue-push! stack (make-func (make-flatten-cont (assq-ref exp1 'args) (cut fold + 0 <>)))))

全コード

(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-add  . args)
  `((type . add)
    (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 (cont? exp)
  (type-eq? exp 'cont))

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

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

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

(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 (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))))
       ((add? exp1)
        (queue-push! stack (make-func (make-flatten-cont (assq-ref exp1 'args) (cut fold + 0 <>)))))
       ((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))
                (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-end)