secd machine(2)

ちょこっと前進。if のサポート。そして初めて secd の d, dump スタックを使った。
元の secd だと、必ず s とか e とかが末尾残っているのだけど、わたしのは空リスト。そのままだと secd の d は結局空のままで分かり難いので、 if の結果に足し算をする例にしてある。既に微妙に表記が資料と違っていて混乱気味。基本的にわたしのは全てカッコが一階層多いようだ。

しかし secd って単純で楽しい。 haskell あたりならパターンマッチだけでものすごく奇麗に書き下せそう。

;; (+ (if (atom 5) 9 7) 11) => 20
gosh> (let1 secd
           (make-secd :c '((LDC 5) (ATOM) (SEL)
                           ((LDC 9) (JOIN))
                           ((LDC 7) (JOIN))
                           (LDC 11)
                           (+)))
         (car (s (run-loop secd))))
#<s:() e:() c:((LDC 5) (ATOM) (SEL) ((LDC 9) (JOIN)) ((LDC 7) (JOIN)) (LDC 11) (+)) d:()> ->
#<s:(5) e:() c:((ATOM) (SEL) ((LDC 9) (JOIN)) ((LDC 7) (JOIN)) (LDC 11) (+)) d:()> ->
#<s:(#t) e:() c:((SEL) ((LDC 9) (JOIN)) ((LDC 7) (JOIN)) (LDC 11) (+)) d:()> ->
#<s:() e:() c:((LDC 9) (JOIN)) d:(((LDC 11) (+)))> ->
#<s:(9) e:() c:((JOIN)) d:(((LDC 11) (+)))> ->
#<s:(9) e:() c:((LDC 11) (+)) d:()> ->
#<s:(11 9) e:() c:((+)) d:()> ->
#<s:(20) e:() c:() d:()>
20

gosh> (let1 secd
          (make-secd :c '((LDC 5) (ATOM) (SEL)
                          ((LDC 9) (JOIN))
                          ((LDC 7) (JOIN))))
        (car (s (run-loop secd))))
#<s:() e:() c:((LDC 5) (ATOM) (SEL) ((LDC 9) (JOIN)) ((LDC 7) (JOIN))) d:()> ->
#<s:(5) e:() c:((ATOM) (SEL) ((LDC 9) (JOIN)) ((LDC 7) (JOIN))) d:()> ->
#<s:(#t) e:() c:((SEL) ((LDC 9) (JOIN)) ((LDC 7) (JOIN))) d:()> ->
#<s:() e:() c:((LDC 9) (JOIN)) d:(())> ->
#<s:(9) e:() c:((JOIN)) d:(())> ->
#<s:(9) e:() c:() d:()>
9
gosh> 

コード。だんだんとオブジェクトじゃなく単なる list でも良かった気がしてきた、、

(define-module secd
  (use gauche.test)
  (use gauche.parameter)
  (use gauche.time)
  (use gauche.sequence)
  (use util.match)
  (use util.queue)
  (use srfi-1))

(select-module secd)
(debug-print-width #f)

;; http://www.cs.ualberta.ca/~you/courses/325/Mynotes/Fun/SECD-slides.html

(define-class <secd> ()
  (;; stack used of evaluation of expressions
   (stack :accessor s :init-value () :init-keyword :s)
   ;; environment used to store the current value list
   (env :accessor e :init-value () :init-keyword :e)
   ;; control used to store the instructions
   (control :accessor c :init-value () :init-keyword :c)
   ;; dump used to store suspended invocation context.
   (dump :accessor d :init-value () :init-keyword :d)))

(define-method write-object ((secd <secd>) port)
  (format port "#<s:~a e:~a c:~a d:~a>"
          (s secd) (e secd) (c secd) (d secd)))

(define (make-secd . options)
  (let-keywords options ((s ()) (e ()) (c ()) (d ()))
    (make <secd> :s s :e e :c c :d d )))

(define-method run-loop ((secd <secd>))
  (format #t "~s" secd)
  (cond
   ((null? (c secd))
    (format #t "~%")
    secd)
   (else
    (format #t " ->~%")
    (let1 code (car (c secd))
      (match code
        (('NIL) ; push a nil pointer
         (push! (s secd) 'nil)
         (pop! (c secd))
         (run-loop secd))
        (('LD i j) ; load from environment ; get a value from context
         (push! (s secd) (list-ref (list-ref (e secd) i) j))
         (pop! (c secd))
         (run-loop secd))
        (('LDC x) ; load constant ;
         (push! (s secd) x)
         (pop! (c secd))
         (run-loop secd))
        (('LDF) ; load function ; get a closure
         #t)
        (('AP) ; apply function
         #t)
        (('RTN) ; return ; restore calling env
         #t)
        (('SEL) ; select in if statement
         (pop! (c secd)) ;; sel
         (let* ((x (pop! (s secd)))
                (ct (pop! (c secd)))
                (cf (pop! (c secd))))
           (push! (d secd) (c secd))
           (set! (c secd) (if x ct cf))
           (run-loop secd)))
        (('JOIN) ; rejoin from control ; used with SEL
         (pop! (c secd)) ;; rm join
         (set! (c secd) (pop! (d secd)))
         (run-loop secd))
        (('RAP) ; recursive apply
         #t)
        (('DUM) ; create a dummy env; used with RAP
         #t)
        (('CAR) ; unary operator car
         (let1 a (pop! (s secd))
           (push! (s secd) (car a))
           (pop! (c secd))
           (run-loop secd)))
        (('ATOM)
         (let* ((a (pop! (s secd))))
           (push! (s secd) (not (pair? a)))
           (pop! (c secd))
           (run-loop secd)))
        ((or ('+) ('-) ('*)) ; binary operator + - *
         (let* ((a (pop! (s secd)))
                (b (pop! (s secd)))
                (op (case (car code)
                      ((+) +)
                      ((-) -)
                      ((*) *))))
           (push! (s secd) (op a b))
           (pop! (c secd))
           (run-loop secd)))
        (else
         (errorf "invalid code: ~a" code)))))))

(provide "secd")

関数のコンパイルは今日はもう時間切れ。まとめて３つ、RET, LDF, AP を実装できなきゃ駄目っぽい。