82 lines
3.1 KiB
Common Lisp
82 lines
3.1 KiB
Common Lisp
|
(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)))
|