;;; 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 #:data-stack #:exec #:exec-str #:repl))

(in-package :scopes/forge)

(defvar *builtins* (make-hash-table :test 'equalp))

(defclass forge-env ()
  ((data-stack :initform nil
			   :reader data-stack
			   :accessor data-stack!)
   (vocabulary :initform (list *builtins*)
			   :accessor vocabulary)))

(defun forge-env ()
  (let ((fe (make-instance 'forge-env)))
	(push (make-hash-table :test 'equalp) (vocabulary fe))
	fe))

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

(defun exec (fe code)
  (dolist (x code)
	(if (symbolp x)
      (funcall (find-word (vocabulary fe) x) fe)
	  (pushd fe x))))

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

(defun find-word (vocab key)
  (let ((k (string-downcase (symbol-name key))) (result nil))
    (dolist (voc vocab)
	  (let ((v (gethash k voc)))
		(if v (return v))))))

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

; built-in primitives

(defun reg-b (key fn) (register *builtins* key fn))

(reg-b "+" #'(lambda (fe) (pushd fe (+ (popd fe) (popd fe)))))
(reg-b "*" #'(lambda (fe) (pushd fe (* (popd fe) (popd fe)))))

(reg-b "dup" #'(lambda (fe) (pushd fe (car (data-stack fe)))))

(reg-b "?" #'(lambda (fe) (format t "~a~%" (popd fe))))
(reg-b "??" #'(lambda (fe) (format t "~a~%" (data-stack fe))))

(reg-b "def" #'(lambda (fe) 
  (let ((name (popd fe)) 
		(code (popd fe)))
    (register (voc fe) name #'(lambda (fe) (exec fe code))))))

(reg-b "const" #'(lambda (fe)
  (let ((name (popd fe))
		(value (popd fe)))
    (register (voc fe) name #'(lambda (fe) (pushd fe value))))))

(reg-b "var" #'(lambda (fe)
  (let ((name (popd fe))
		(var (list (popd fe))))
    (register (voc fe) name #'(lambda (fe) 
	  (pushd fe #'(lambda (fn) 
        (funcall fn var))))))))

(reg-b "get" #'(lambda (fe)
  (funcall (popd fe) #'(lambda (x) (pushd fe (car x))))))

(reg-b "put" #'(lambda (fe)
  (let ((fn (popd fe))
		(vl (popd fe)))
    (funcall fn #'(lambda (x) (setf (car x) vl))))))

; internal definitions

(defun voc (fe) (car (vocabulary fe)))

(defun popd (fe) (pop (data-stack! fe)))

(defun pushd (fe v) (push v (data-stack! fe)))