;;; 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)))
(defclass forge-env ()
  ((data-stack :initform nil
               :accessor data-stack)
   (cp :initform (make-iseq)
       :accessor cp)
   (ip :initform (make-iseq)
       :accessor ip)))

;;; forge environment

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

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

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

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

(defun exec (code)
  (dolist (x code)
    (typecase x
      (symbol (funcall (comp1 x)))
      (compiled-function (funcall x))
      (t (pushd x)))))

(defun call (code)
  (dolist (x code)
    (funcall x)))

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

(defun find-word (key))

(defun comp (inp)
  (let ((code nil))
    (dolist (item inp)
      (setf code (cons (comp1 item) code)))
    (reverse code)))

(defun comp1 (item)
  (typecase item
    (symbol (find-word item))
    (cons (comp item))
    (t item)))

(defun register (voc key fn)
  (let ((k (if (symbolp key) (symbol-name key) key)))
    (setf (gethash (string-downcase k) voc) fn)))

; internal definitions

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

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