Toy forth implementation in Common Lisp

forth.lisp

(in-package :cl-user)
(defpackage forth
  (:use :cl)
  (:export :run
           :clear
           :create-context))
(in-package :forth)

(defstruct context
  (dictionary (make-hash-table :test 'equal))
  (stack nil))

(defmacro context-word (context word)
  `(gethash (string ,word) (context-dictionary ,context)))

(defmacro context-pop (context)
  `(pop (context-stack ,context)))

(defmacro context-push (context value)
  `(push ,value (context-stack ,context)))

(defun prepare-builtins (context)

  ;; simple operators
  (dolist (operator '(+ - * /))
    (setf (context-word context operator)
          (lambda (context)
            (context-push context
                          (apply operator
                                 (reverse (list (context-pop context)
                                                (context-pop context))))))))

  ;; begin buildin functions
  (macrolet ((defword (word &body body)
               `(setf (context-word context (quote ,word))
                      (lambda (context)
                        ,@body)))
             (cpop ()
               `(context-pop context))
             (cpush (value)
               `(context-push context ,value)))

    (defword drop
        (cpop))

    (defword 2drop
        (cpop) (cpop))

    (defword nip
        (let ((a (cpop)))
          (cpop)
          (cpush a)))

    (defword dup
        (let ((a (cpop)))
          (cpush a)
          (cpush a)))

    (defword swap
        (let ((a (cpop))
              (b (cpop)))
          (cpush a)
          (cpush b)))

    (defword and
        (cpush (boole boole-and (cpop) (cpop))))

    (defword or
        (cpush (boole boole-ior (cpop) (cpop))))
  
    (defword xor
        (cpush (boole boole-xor (cpop) (cpop))))

    (defword lshift
        (let ((n (cpop)))
          (cpush (ash (cpop) n))))

    (defword rshift
        (let ((n (cpop)))
          (cpush (ash (cpop) (- n)))))

    ;; end buildin functions
    ))

(defun create-context ()
  (let ((context (make-context)))
    (prepare-builtins context)
    context))

(defparameter *default-context* (create-context))

(defun run (list &key (context *default-context*))
  (dolist (value list)
    (case (type-of value)
      ('symbol
       (let ((item (context-word context value)))
         (funcall item context)))
      (otherwise
       (push value (context-stack context)))))
  (reverse (context-stack context)))

(defun clear (&key (context *default-context*))
  (setf (context-stack context) nil))

> (forth:run '(1 2 +))
(3)
> (forth:run '(drop))
NIL