cl-scopes/forge/forge.lisp

;;;; cl-scopes/forge - may the forge be with you!

;;;; A Forth-like interpreter implemented in Common Lisp.

(defpackage :scopes/forge
  (:use :common-lisp)
  (:export #:*forge-env* #:setup-builtins #:activate-package
           #:forge-env #:dstack #:exec #:exec-str #:repl
           #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add
           #:with-trace))

(defpackage :sf-builtin)
(defpackage :sf-user)

(in-package :scopes/forge)

(defmacro with-trace (&body body)
  `(let ((*features* (cons :forge-trace *features*))) ,@body))

;;; iseq: iterable sequence

(defclass iseq ()
  ((start :reader start :initform (list nil) :initarg :start)
   (cur :accessor cur)
   (end :accessor end)))

(defun make-iseq (&optional start)
  (let* ((start (cons nil start))
         (seq (make-instance 'iseq :start start)))
    (setf (cur seq) (setf (end seq) start))
    seq))

(defun isq-all (seq)
  (cdr (start seq)))

(defun isq-cur (seq)
  (car (cur seq)))

(defun isq-end (seq)
  (car (end seq)))

(defun isq-next (seq)
  (pop (cur seq))
  (car (cur seq)))

(defun isq-add (seq v)
  (setf (cdr (end seq)) (list v))
  (pop (end seq)))

;;; forge environment

(defclass forge-env ()
  ((data-stack :initform nil :accessor data-stack)
   (words :initform (make-hash-table))
   (comp-words :initform (make-hash-table))
   (packages :initform '(:sf-user :sf-builtin))
   (current-package :initform :sf-builtin)
   (rp :initform (make-iseq))
   (cp :initform (make-iseq))
   (ip :initform (make-iseq))))

(defun forge-env ()
  (make-instance 'forge-env))

(defvar *forge-env* (forge-env))

(defun activate-package(p)
  (let ((old (current-package)))
    (setf (slot-value *forge-env* 'current-package) p)
    old))

(defun dstack() (data-stack *forge-env*))

(defun words () (slot-value *forge-env* 'words))

(defun comp-words () (slot-value *forge-env* 'comp-words))

(defun register-comp-word (sym fn)
  (register sym fn 'comp-words))

(defun register (sym fn &optional (slot 'words))
  (let* ((w (intern (string sym) (current-package)))
         (words (slot-value *forge-env* slot)))
    (setf (gethash w words) fn)))

;;; builtins

(defmacro reg (sym &body body)
  `(register ',sym #'(lambda () ,@body)))

(defun lit () (pushd (isq-next (fip))))
(defun wrap () (pushd (list #'lit (popd))))
(defun defer () (comp-item (isq-next (fip))))

(defun do-reg ()
  (let* ((name (popd))
         (code (popd)))
    (register name #'(lambda () (call code)))))

(defun do-regc ()
  (let* ((name (popd))
         (code (popd)))
    (register-comp-word name #'(lambda () (call code)))))

(defun do-quote () (comp-item #'lit) (comp-item (read-next)))

(defun do-comp () 
  (let* ((sym (read-next))
         (w (get-word sym)))
    #+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
    (comp-item (gethash w (comp-words)))))

(defun setup-builtins ()
  (reg + (pushd (+ (popd) (popd))))
  (reg * (pushd (* (popd) (popd))))
  (reg dup (pushd (car (dstack))))
  (reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))

  (register 'lit #'lit)
  (register 'wrap #'wrap)
  (register 'defer #'defer)
  (register 'reg #'do-reg)
  (register 'regc #'do-regc)

  (register-comp-word 'quote #'do-quote)
  (register-comp-word 'comp #'do-comp)

  (activate-package :sf-user))

;;; compiler, interpreter

(defun exec-str (s)
  (exec (read-from-string 
             (concatenate 'string "(" s ")"))))

(defun repl ()
  (do ((input (read-line) (read-line))) ((string= input "q") nil)
    (exec-str input)))

(defun exec (code)
  (call (comp code)))

(defun call (code)
  #+forge-trace (print code)
  (let ((old-ip (fip))
        (ip (make-iseq code)))
    (setf (slot-value *forge-env* 'ip) ip)
    (do ((item (isq-next ip) (isq-next ip)))
        ((null item))
      (funcall item))
    (setf (slot-value *forge-env* 'ip) old-ip)))

(defun comp (slist)
  #+forge-trace (print slist)
  (let ((cp (make-iseq))
        (inp (make-iseq slist)))
    (setf (slot-value *forge-env* 'cp) cp)
    (setf (slot-value *forge-env* 'rp) inp)
    (do ((item (isq-next inp) (isq-next inp)))
        ((null item))
      (typecase item
        (symbol (comp-symbol item))
        (cons (let ((sub (comp item)))
                (setf (slot-value *forge-env* 'cp) cp)
                (setf (slot-value *forge-env* 'rp) inp)
                (comp-item #'lit)
                (comp-item sub)))
        (t (comp-item #'lit) (comp-item item)))))
  (isq-all (fcp)))

(defun comp-symbol (sym)
  (let* ((w (get-word sym))
         (comp-fn (gethash w (comp-words))))
    ;(format t "~%comp-symbol ~a ~a ~a" sym w comp-fn)
    (if comp-fn
      (funcall comp-fn)
      (comp-item (gethash w (words))))))

(defun get-word (sym)
  (let ((name (string sym)))
    (dolist (p (packages))
      (let ((w (find-symbol name p)))
        (if w 
          (return-from get-word w))))))

;;; internal definitions / forge-env pseudo-methods

(defun popd () (pop (data-stack *forge-env*)))

(defun pushd (v) (push v (data-stack *forge-env*)))

(defun fcp () (slot-value *forge-env* 'cp))

(defun comp-item (item) (isq-add (fcp) item))

(defun fip () (slot-value *forge-env* 'ip))

(defun read-next () (isq-next (slot-value *forge-env* 'rp)))

(defun packages () (slot-value *forge-env* 'packages))

(defun current-package () (slot-value *forge-env* 'current-package))