;;; 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*
           #:forge-env #:dstack #:exec #:exec-str #:repl
           #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))

(in-package :scopes/forge)

;;; 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)
   (cp :initform (make-iseq))
   (ip :initform (make-iseq))))

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

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

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

;;; builtins

(defvar add #'(lambda () (pushd (+ (popd) (popd)))))

(defvar lit #'(lambda () (pushd (isq-next (fip)))))

;;; 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)
  (let ((ip (make-iseq code)))
    (setf (slot-value *forge-env* 'ip) ip)
    (do ((item (isq-next ip) (isq-next ip)))
        ((null item))
      (funcall item))))

(defun get-word (sym)
  (symbol-value (find-symbol (string sym) :scopes/forge)))

(defun comp (slist)
  (setf (slot-value *forge-env* 'cp) (make-iseq))
  (let ((inp (make-iseq slist)))
    (do ((item (isq-next inp) (isq-next inp))) 
        ((null item))
      (typecase item
        (symbol (comp1 (get-word item)))
        (cons (comp1 lit) (comp1 (comp item)))
        (t (comp1 lit) (comp1 item)))))
  (isq-all (fcp)))

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

;;; internal definitions

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

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

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

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