ese-eval3 - begin (was 写経)

make-begin-cont の invoke-proc が2種類。
(begin 1 (begin 2 3)) の計算経過を絵に描いてみると分かるけどスタックの使われ方が違う。
引数の eval の結果を待っている自分自身をスタックから pop してしまうところがポイントか。

(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)
  (print "\n==== stack ======")
  (for-each (lambda (e)
              (display "     ")
              (print (assq-ref e 'type))
              (print "***************"))
            (queue->list queue)))

;; (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) (last-value '()))
    (lambda (func)
;; optimized
;;       (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))))

;; not optimized
      (define (invoke-proc)
        (if (< arg-index (length row-args))
            (make-need-sub-exp (list-ref row-args arg-index))
            (make-int last-value)))
      (define (resume retval)
        (set! last-value 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))))))

(ese-eval (make-begin (make-begin (make-int 5) (make-begin (make-int 3) (make-int 10))) (make-int 12)))