(in-package #:cl-forth)

(defparameter *compile-mode* nil)
(defparameter *current-definition* nil)

(define-condition unknown-word-error (error)
  ((token :initarg :token
          :accessor token-of))
  (:report (lambda (condition stream)
             (format stream "Unknown word: ~a.~&" (token-of condition)))))

(defclass interpreter ()
  ((current-token :accessor current-token-of)
   (stack :initform (make-instance 'stack)
          :accessor stack-of)
   (words :initform (make-hash-table :test 'equal)
          :accessor words-of)
   (line :accessor line-of)))

(defmethod initialize-instance :after ((interp interpreter) &key &allow-other-keys)
  "Initialize a new interpreter with basic operations."
  (setf (gethash "+" (words-of interp)) #'add
        (gethash "-" (words-of interp)) #'subtract
        (gethash "*" (words-of interp)) #'multiply
        (gethash "/" (words-of interp)) #'divide
        (gethash "mod" (words-of interp)) #'mod
        (gethash "dup" (words-of interp)) #'dup
        (gethash "swap" (words-of interp)) #'swap
        (gethash "negate" (words-of interp)) #'negate
        (gethash "drop" (words-of interp)) #'drop
        (gethash "over" (words-of interp)) #'over
        (gethash "rot" (words-of interp)) #'rot)
    interp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod evaluate-line ((obj interpreter))
  (let ((tokens (split-string #\Space (line-of obj))))
    (dolist (token tokens)
      (cond
        ((equal token ":")
         (setf *compile-mode* t))
        ((equal token ";")
         (setf *compile-mode* nil)
         ;; save the definition
         (setf (gethash (car *current-definition*) (words-of obj))
               (reverse (cdr *current-definition*))
               *current-definition* nil))
        (*compile-mode*
         (if (null *current-definition*)
             ;; First token is the name of the new word
             (setf *current-definition* (list token))
             ;; Subsequent tokens are the body of the word
             (push token (cdr *current-definition*))))
        (t
         (setf (current-token-of obj) token)
         (execute-word obj))))))

(defmethod execute-word ((obj interpreter))
  (let ((token (current-token-of obj)))
    (cond
      ((digit-char-p (elt token 0))
       ;; Push numbers onto the stack
       (push-to-stack (stack-of obj) (parse-integer token)))
      ((gethash token (words-of obj))
       ;; If token is in dictionary, execute it
       (let ((definition (gethash token (words-of obj))))
         (if (functionp definition)
             ;; If it's a primitive word, just execute it
             (funcall definition obj)
             ;; If it's a user-defined word, interpret each token in it
             (dolist (word definition)
               (setf (current-token-of obj) word)
               (execute-word obj)))))
      (t
       (error 'unknown-word-error :token token)))))

(defmethod interpret ((obj interpreter) program)
  "Interpret a PROGRAM using the INTERP."
  (setf (line-of obj) program)
  (evaluate-line obj)
  (format t "Stack after execution: ~a~%" (stack-of obj)))