secd machine

分かりやすそうな http://www.cs.ualberta.ca/~you/courses/325/Mynotes/Fun/SECD-slides.html を元に SECD マシーンを作って見ている途中。ほとんど定義そのままの単純な構造。良くわかっていないが、まだ実装していない LDF あたりが楽しみ。

OP	説明	目的	状態
NIL	push a nil	list 用	done
LD	環境から値を取得		done
LDC	スタックに定数をプッシュ		done
LDF
AP
RTN
SEL
JOIN
RAP
DUM
CAR	built in unary op.	リスト操作	done
+,-,*	built in binary op.	数値演算	done

gosh> (run-loop (make-secd '((LDC 3) (LDC 2) (LDC 6) (+) (*)) '()))
#<secd: s:() e:() c:((LDC 3) (LDC 2) (LDC 6) (+) (*)) ()>
#<secd: s:(3) e:() c:((LDC 2) (LDC 6) (+) (*)) ()>
#<secd: s:(2 3) e:() c:((LDC 6) (+) (*)) ()>
#<secd: s:(6 2 3) e:() c:((+) (*)) ()>
#<secd: s:(8 3) e:() c:((*)) ()>
#<secd: s:(24) e:() c:() ()>
#<secd: s:(24) e:() c:() ()>

unit test.

(test* "ldc"
       3
       (let1 secd
           (make-secd '((LDC 3)) '())
         (car (stack (run-loop secd)))))

(test* "ldc"
       '(3 5)
       (let1 secd
           (make-secd '((LDC 5) (LDC 3)) '())
         (stack (run-loop secd))))

(test* "ldc in SECD-slides.html"
       24
       (let1 secd
           (make-secd '((LDC 3) (LDC 2) (LDC 6) (+) (*)) '())
         (car (stack (run-loop secd)))))

SECD Machine のコード。

(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 ofr evaluation of expressions
   (stack :accessor stack :init-value ())
   ;; environment used to store the current value list
   (env :accessor env :init-value () :init-keyword :env)
   ;; control used to store the instructions
   (control :accessor control :init-value () :init-keyword :control)
   ;; dump used to store suspended invocation context.
   (dump :accessor dump :init-value ())))

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

(define (make-secd control env) (make <secd> :control control :env env))

(define-method run-loop ((secd <secd>))
  (format #t "~s" secd)
  (cond
   ((null? (control secd))
    secd)
   (else
    (let1 code (car (control secd))
      (match code
        (('NIL) ; push a nil pointer
         (push! (stack secd) 'nil)
         (pop! (control secd))
         (run-loop secd))
        (('LD i j) ; load from environment ; get a value from context
         (push! (stack secd) (list-ref (list-ref (env secd) i) j))
         (pop! (control secd))
         (run-loop secd))
        (('LDC x) ; load constant ;
         (push! (stack secd) x)
         (pop! (control 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
         #t)
        (('JOIN) ; rejoin from control ; used with SEL
         #t)
        (('RAP) ; recursive apply
         #t)
        (('DUM) ; create a dummy env; used with RAP
         #t)
        (('CAR) ; unary operator car
         (let1 a (pop! (stack secd))
           (push! (stack secd) (car a))
           (pop! (control secd))
           (run-loop secd)))
        ((or ('+) ('-) ('*)) ; binary operator + - *
         (let* ((a (pop! (stack secd)))
                (b (pop! (stack secd)))
                (op (case (car code)
                      ((+) +)
                      ((-) -)
                      ((*) *))))
           (push! (stack secd) (op a b))
           (pop! (control secd))
           (run-loop secd)))
        (else
         (errorf "invalid code: ~a" code)))))))

(provide "secd")

追記。お、トラックバックを頂いた。多謝。これは最後まで頑張らなくては。
SECD in scheme -> Tail-Recursive SECD in scheme -> toy Gauche VM in scheme -> (Full Gauche VM in scheme)、と進めると素敵なのだけどまだ最初なのでかなり遠い道のり。