Lisp / CLOS version of http://ruslanspivak.com/lsbasi-part3/

simple-interpreter-3.lisp

; http://ruslanspivak.com/lsbasi-part3/

; Lisp / CLOS version Rainer Joswig, joswig@lisp.de, 2015


;;; ================================================================
;;; Token

(defclass token ()
  ((type  :accessor token-type  :initarg :type)
   (value :accessor token-value :initarg :value)))

(defmethod print-object ((object token) stream)
  (print-unreadable-object (object stream)
    (with-slots (type value) object
      (format stream "type ~a value ~a" type value))))


;;; ================================================================
;;; Interpreter

(defclass interpreter ()
  ((text          :initarg :text)
   (pos           :initform 0)
   (current-token :initform nil)
   (current-char  :initform nil)))

(defmethod initialize-instance :after ((ip interpreter) &rest initargs)
  (declare (ignore initargs))
  (with-slots (current-char text pos) ip
    (setf current-char (aref text pos))))

(defmethod advance ((ip interpreter))
  "Advance the `pos` pointer and set the `current_char` variable."
  (with-slots (pos text current-char) ip
    (incf pos)
    (setf current-char
          (if (> pos (1- (length text)))
              nil
            (aref text pos)))))

(defun space-p (char)
  (member char '(#\space #\tab)))

(defmethod skip-whitespace ((ip interpreter))
  (with-slots (current-char) ip
    (loop while (and current-char (space-p current-char))
          do (advance ip))))

(defmethod get-integer ((ip interpreter))
  "Return a (multidigit) integer consumed from the input."
  (with-slots (current-char) ip
    (parse-integer
     (with-output-to-string (result)
       (loop while (and current-char (digit-char-p current-char)) do
             (write-char current-char result)
             (advance ip))))))

(defmethod get-next-token ((ip interpreter))
  "Lexical analyzer (also known as scanner or tokenizer)
This method is responsible for breaking a sentence
apart into tokens. One token at a time."
  (with-slots (current-char) ip
    (loop while current-char do
          (cond ((space-p current-char)
                 (skip-whitespace ip))
                ((digit-char-p current-char)
                 (return-from get-next-token (make-instance 'token :type :integer :value (get-integer ip))))
                ((char= current-char #\+)
                 (advance ip)
                 (return-from get-next-token (make-instance 'token :type :plus :value '+)))
                ((char= current-char #\-)
                 (advance ip)
                 (return-from get-next-token (make-instance 'token :type :plus :value '-)))
                (t (error "parse error getting next token")))))
  (make-instance 'token :type :eof :value :eof))

(defmethod eat ((ip interpreter) token-type)
"compare the current token type with the passed token
type and if they match then eat the current token
and assign the next token to the self.current_token,
otherwise raise an exception."
  (with-slots (current-token) ip
    (if (eq (token-type current-token) token-type)
        (setf current-token (get-next-token ip))
      (error "parse error for token type ~a" token-type))))

(defmethod term ((ip interpreter))
  "Return an INTEGER token value"
  (with-slots (current-token) ip
    (let ((token current-token))
      (eat ip :integer)
      (token-value token))))

(defmethod expr ((ip interpreter))
  "Arithmetic expression parser / interpreter."
  (with-slots (current-token) ip
    (setf current-token (get-next-token ip))
    (let ((result (term ip)))
      (loop while (member (token-type current-token) '(:plus :minus)) do
            (case (token-type current-token)
              (:plus (eat ip :plus)
               (setf result (+ result (term ip))))
              (:minus (eat ip :minus)
               (setf result (- result (term ip))))))
      result)))


;;; ================================================================
;;; main function CALC

(defun calc ()
  (loop
   (format t "~%calc> ")
   (force-output)
   (with-simple-restart (abort "calc toplevel")
     (let ((line (read-line)))
       (if (plusp (length line))
           (format t "~a" (expr (make-instance 'interpreter :text line)))
         (return))))))