小さな Forth もどきを作ってみた

(def-primitive :|create| のことろで codes-index を 0 に設定してなかったので、2回目以降の呼び出しが何もせず終っていた。
修正した。(2005/05/05)

今日はちょっと初心にかえって小さな Forth もどきを作ってみた。
実装は Common Lisp で、参考にしたのはもちろん jonesforth.

: 1+ 1 + ;
9 1+ .

で10を出力くらしか動かないけど。

それでもこんな小さなコードでまがりなりにもプログラムが動くってのは不思議に思える。

(defparameter *data-stack* nil)
(defparameter *return-stack* nil)
(defparameter *code-point* nil)
(defparameter *dictionary* (make-hash-table))

(defstruct codes
  (codes (make-array 0 :adjustable t :fill-pointer t))
  (index 0))

(defun codes-next (&optional (codes *code-point*))
  (unless (codes-end-p codes)
    (prog1
        (aref (codes-codes codes) (codes-index codes))
      (incf (codes-index codes)))))

(defun codes-end-p (&optional (codes *code-point*))
  (>= (codes-index codes) (length (codes-codes codes))))

(defun run ()
  (loop
     while
     (progn
       (loop while (and *code-point* (codes-end-p))
          do (setf *code-point* (por)))
       ;;(format t "~%~s~%~s~%~s~%" *return-stack* *data-stack* *code-point*)
       *code-point*)
     do (let ((word (codes-next)))
          (let ((def (fnd word)))
            (if def
                (funcall def)
                (error "~s is unbound." word))))))

(defun put-dic (k v)
  (setf (gethash k *dictionary*) v))

(defun get-dic (k)
  (gethash k *dictionary*))

(defmacro def-primitive (word (&optional immediate) &body body)
  `(progn
     (setf (get ',word 'immediate) ,immediate)
     (put-dic ,word #'(lambda () ,@body))))

(defmacro def-word (word (&optional immediate) &body body)
  `(progn
     (setf (get ',word 'immediate) ,immediate)
     (put-dic ,word #'(lambda ()
                        (pur *code-point*)
                        (setf *code-point*
                              (make-codes :codes (coerce ',body 'vector)))))))

(defun fnd (word)
  (get-dic word))

(defun po ()
  (pop *data-stack*))

(defun pu (x)
  (push x *data-stack*))

(defun por ()
  (pop *return-stack*))

(defun pur (x)
  (push x *return-stack*))


(def-primitive :|t| ()
               (pu t))
(def-primitive :|nil| ()
               (pu nil))
(defgeneric g= (x y)
  (:method (x y)
    (equal x y)))
(def-primitive :|=| ()
               (pu (g= (po) (po))))

(def-primitive :|dup| ()
               (pu (car *data-stack*)))

(def-primitive :|+| ()
               (pu (+ (po) (po))))

(def-primitive :|.| ()
               (print (po)))

(def-primitive :|lit| ()
               (pu (codes-next)))
(def-primitive :|exit| ()
               (setf *code-point* (por)))
(def-primitive :|create| ()
               (let ((word (po)))
                 (let ((codes (make-codes)))
                   (put-dic word #'(lambda ()
                                     (pur *code-point*)
                                     (setf (codes-index codes) 0)
                                     (setf *code-point* codes)))
                   (def-primitive :|latest| ()
                                  codes))))
(defun latest ()
  (funcall (fnd :|latest|)))
(defun comma (word)
  (let ((codes (latest)))
    (vector-push-extend word (codes-codes codes))))
(def-primitive :|,| ()
               (comma (po)))
(def-primitive :|immediate| (t)
               (let ((latest (latest)))
                 (maphash #'(lambda (k v)
                              (when (eq v latest)
                                (setf (get k 'immediate) t)))
                          *dictionary*)))
(def-primitive :|branch| ()
               (let ((offset (1- (codes-next)))) ; 1- is offset it self.
                 (incf (codes-index *code-point*) offset)))
(def-primitive :|0branch| ()
               (if (po)
                   (incf (codes-index *code-point*))
                   (incf (codes-index *code-point*)
                     (codes-next))))

(def-primitive :|cons| ()
               (let ((y (po))
                     (x (po)))
                 (pu (cons x y))))
(def-primitive :|car| ()
               (pu (car (po))))
(def-primitive :|cdr| ()
               (pu (cdr (po))))
(def-primitive :|cons?| ()
               (pu (consp (po))))

(def-primitive :|{}| ()
               (pu (make-hash-table)))

(def-primitive :|*stdin*| ()
               (pu *standard-input*))
(def-primitive :|read-char| ()
               (pu (read-char (po) nil nil)))
(def-primitive :|*stdout*| ()
               (pu *standard-output*))
(def-primitive :|write-char| ()
               (let ((stream (po))
                     (char (po)))
                 (write-char char stream)))

(defun word ()
  (let ((scaned (with-output-to-string (out)
                  (loop for c = (read-char *standard-input* nil nil)
                     if (char> c #\space)
                     do (return (write-char c out)))
                  (loop for c = (read-char *standard-input* nil nil)
                     do (if (char> c #\space)
                            (write-char c out)
                            (return))))))
    (intern scaned :keyword)))
(def-primitive :|word| ()
               (pu (word)))

(def-primitive :|state| ()
               (pu nil))
(def-primitive :|[| (t)
               (def-primitive :|state| ()
                              (pu nil))) ; immediate mode
(def-primitive :|]| ()
               (def-primitive :|state| ()
                              (pu t)))  ; compile mode

(def-word :|quit| ()
          :|interpret|
          :|branch|
          -2)

(def-primitive
    :|interpret| ()
    (let ((word  (progn
                   ;;(format t "~%~s~%~s~%~s~%" *return-stack* *data-stack* *code-point*)
                   (word))))
      (when (eq word :|bye|)
        (break))
      (let ((fnd (fnd word)))
        (if fnd
            (if (get word 'immediate)
                (funcall fnd)
                (if (progn (funcall (fnd :|state|)) (po))
                    (comma word)
                    (funcall fnd)))
            (let ((literal (read-from-string (symbol-name word))))
              (when (symbolp literal)
                (error "~s is unknown." word))
              (if (progn (funcall (fnd :|state|)) (po))
                  (progn
                    (comma :|lit|)
                    (comma literal))
                  (pu literal)))))))


(def-word :|:| ()
          :|word| :|create| :|]|)
(def-word :|;| (t)
          :|[|)


;;;; 以下テスト
(def-word :|double| ()
          :|+| :|+|)

(progn
  (setf *code-point*
        (make-codes :codes #(:|lit| 1 :|lit| 2 :|lit| 3 :|double|)))
  (run)
  (assert (= 6 (print (po)))))

(progn
  (setf *code-point*
        (make-codes
         :codes
         #(:|lit| 1 :|lit| 2 :|lit| 3 :|lit| 4 :|lit| 5
           :|lit| :|triple| :|create|
           :|lit| :|+| :|,|
           :|lit| :|+| :|,|
           :|lit| :|+| :|,|
           :|lit| :|+.| :|create|
           :|lit| :|+| :|,|
           :|lit| :|dup| :|,|
           :|lit| :|.| :|,|
           :|triple|
           :|+.|)))
  (run)
  (assert (= 15 (print (po)))))

(progn
  (setf *code-point* (make-codes :codes #(:|quit|)))
  (run))