;;; 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))

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

(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)
   (words :initform (make-hash-table))
   (comp-words :initform (make-hash-table))
   (packages :initform '(:sf-user :sf-builtin))
   (current-package :initform :sf-user)
   (rp :initform (make-iseq))
   (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*))

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

(defun set-word (w fn) (setf (gethash w (words)) fn))

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

(defun set-comp-word (w fn) (setf (gethash w (comp-words)) fn))

(defun register-comp-word (sym fn &optional p)
  (let ((p (or p (current-package))))
    (set-comp-word (intern (string sym) p) fn)))

(defun register (sym fn &optional p)
  (let ((p (or p (current-package))))
    (set-word (intern (string sym) p) fn)))

;;; builtins

(defun reg-b (sym fn)
  (register sym fn :sf-builtin))

(reg-b 'add #'(lambda () (pushd (+ (popd) (popd)))))
(reg-b 'mul #'(lambda () (pushd (* (popd) (popd)))))

(reg-b 'dup #'(lambda () (pushd (car (dstack)))))

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

(register-comp-word 'def
  #'(lambda () 
      (let* ((name (isq-next (frp)))
             (code (comp (isq-next (frp)))))
        (register name #'(lambda () (call code)))))
  :sf-builtin)

;;; 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 comp (slist)
  (setf (slot-value *forge-env* 'cp) (make-iseq))
  (let ((inp (make-iseq slist)))
    (setf (slot-value *forge-env* 'rp) inp)
    (do ((item (isq-next inp) (isq-next inp))) 
        ((null item))
      (typecase item
        (symbol (comp-symbol item))
        (cons (comp-item lit) (comp-item (comp item)))
        (t (comp-item lit) (comp-item item)))))
  (isq-all (fcp)))

(defun comp-symbol (sym)
  (let* ((w (get-word sym))
         (comp-fn (get-comp-fn w)))
    (if comp-fn
      (funcall comp-fn)
      (comp-item (gethash w (words))))))

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

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

(defun get-comp-fn (w)
  (gethash w (comp-words)))

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

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

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

(defun frp () (slot-value *forge-env* 'rp))

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

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

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

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