ryos36の日記 (Scheme Switch)

 | 

2008-01-06

SICP の5章

10:52

goto を実現するための習作

(defun jump-test (lst stack)
  (let ((one (car lst))
        (remain (cdr lst)))
    (format t "do ~a~%" one)
    (cond ((consp one) (cond ((eq (car one) 'goto) (gethash (cadr one) stack))
                             (t remain)))
          (t (setf (gethash one stack) remain)
             remain))))

(setf stack (make-hash-table))
(setf lst '(
            label
            (op something)
            (goto label)))

(setf lst (jump-test lst stack))
(format t "~a~%" stack)
(setf lst (jump-test lst stack))
(setf lst (jump-test lst stack))
(setf lst (jump-test lst stack))
(setf lst (jump-test lst stack))
(setf lst (jump-test lst stack))

一応動くぞ。 basic 位作れそうだな。

make-machine の習作

SICP のソースを見ずに作ったのでめちゃくちゃ。しかも中途半端。あくまで習作。

(defun niy (func) (error "NIY ~a" func))

(defstruct register-machine-instance
  regs
  opes
  controller)

(defun make-machine (regs opes controller)
  (let ((machine (make-register-machine-instance
                   :regs regs
                   :opes opes
                   :controller controller))
        )
    (let* (
           (eval-operand #'(lambda (operand)
                             (let ((s (car operand)))
                               (cond ((eq s 'regs) (gethash (cadr operand) regs)
)
                                     ((eq s 'const) (cadr operand))
                                     (t
                                       (assert (eq s 'op))
                                       (niy "eval-op"))))))

           (assign #'(lambda (regs-name operand)
                       (setf (gethash regs-name regs)
                         (funcall eval-operand operand)))))
      (let ((dispatch #'(lambda (m)
                          (cond ((eq m 'machine) machine)
                                (t nil)))))
        (funcall assign 'a '(const 33))
        (format t "eval ~a~%"
                (funcall eval-operand '(regs a)))
        dispatch))))
;--------------------------------------------------------------------------
(setf regs (make-hash-table))
(setf (gethash 'a regs) 4)
;(push 0 (gethash 'a regs))
(setf machine (make-machine regs nil nil))
(format t "~a~%" machine)
(format t "~a~%" (funcall machine 'machine))
(format t "~a~%" (eval-operand '(const 4)))

一応動いているようだが、、、SICP とは直接関係ない。

 |