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

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

(defpackage :scopes/forge/sf
  (:use :common-lisp)
  (:local-nicknames (:iter :scopes/util/iter))
  (:export #:*input* #:*stack*
           #:word #:comp-word
           #:exec-list #:exec-input #:comp-input #:call
           #:lit #:reg #:reg2 #:reg-code
           #:pushd #:popd #:peekd))

(in-package :scopes/forge/sf)

(defvar *stack* nil)
(defvar *input* nil)
(defvar *buffer* nil)
(defvar *code* nil)
(defvar *func-index* (make-hash-table))

(defmethod print-object :around ((fn function) s)
  (let ((sym (gethash fn *func-index*)))
    (if sym
      (print-unreadable-object (fn s) (format s "~s" sym))
      (call-next-method))))

;;;; core definitions

(defgeneric exec-item (it)
  (:method ((it t))
    (pushd it))
  (:method ((it symbol))
    (exec-item (symbol-value it))))

(defgeneric comp-item (it)
  (:method ((it t))
    (push #'lit *buffer*)
    (push it *buffer*))
  (:method ((it symbol))
    (comp-item (symbol-value it))))

;;;; class word*

(defclass word () 
  ((func :reader func :initarg :func)))

(defmethod exec-item ((w word))
  (funcall (func w)))

(defmethod comp-item ((w word))
  (push (func w) *buffer*))

;;;; class comp-word

(defclass comp-word (word) ())

(defmethod comp-item ((w comp-word))
  (funcall (func w)))

;;;; functions

(defun exec-list (lst)
  (let ((*input* (make-instance 'iter:list-iterator :data lst)))
    (exec-input)))

(defun exec-input ()
  (iter:process *input* #'exec-item))

(defun comp-input ()
  (let ((*buffer* nil))
    (iter:process *input* #'comp-item)
    (pushd (reverse *buffer*))))

(defun call (code)
  (let ((*code* (make-instance 'iter:list-iterator :data code)))
    (iter:process *code* #'funcall)))

(defun reg (sym fn &optional (cls 'word))
  (setf (symbol-value sym) (make-instance cls :func fn))
  (setf (gethash fn *func-index*) sym))

(defun reg2 (sym fn)
  (reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))

(defun reg-code (&optional (cls 'word))
  (let ((name (popd))
        (code (popd)))
    (reg name #'(lambda () (call code)) cls)))

(defun pushd (v)
  (push v *stack*))

(defun popd ()
  (pop *stack*))

(defun peekd ()
  (car *stack*))

(defun lit () 
  (pushd (iter:next-value *code*)))

;;;; builtins

(defpackage :sf-builtin
  (:use :common-lisp)
  (:local-nicknames (:f :scopes/forge/sf)
                    (:iter :scopes/util/iter))
  (:export #:add #:mul #:dup #:in #:? #:lit
           #:<comp #:reg #:regc #:/>))

(in-package :sf-builtin)

(f:reg2 'add #'+)
(f:reg2 'mul #'*)

(f:reg 'dup #'(lambda () (f:pushd (f:peekd))))

(f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))

(f:reg 'lit #'f:lit)

(f:reg '<comp #'f:comp-input)

(f:reg 'reg #'f:reg-code)
(f:reg 'regc #'(lambda () (f:reg-code 'f:comp-word)))

(f:reg '/> #'(lambda () (iter:stop f:*input*)) 'f:comp-word)