Brainfuck Interpreter in Common Lisp

;;;; Created on 2011-03-09 19:46:53
; Updated to v0.1: 2011-08-05 23:40:51

;;;; The author is indebted to Sylwester (http://sylwester.no/)
;;;; for accidentally being my very first tester

(defparameter *tape* (make-array 100 :initial-element 0))
(defparameter *position* 0)
(defparameter *userposition* 0)
(defparameter *openbracket-appear* 0)
(defparameter *closebracket-appear* 0)
(defparameter loopback-appear 0) ;Piece of shit helper variable that doesn't even deserve its earmuffs
(defparameter loopforward-appear 0)

;(defparameter *errors* (make-hash-table))
;;Defining error types:
;   (setf (gethash 'input-type-str *errors*) '(Input cannot be of type string))
;   (setf (gethash 'input-type-nil *errors*) '(Input cannot be of type null))
;   (setf (gethash 'tape-string *errors*)    '(Cannot concatenate string with number objects))
;   (setf (gethash 'input-unknown *errors*)  '(Input unknown or invalid))

;(defun err (code)
;   (format t "~&Error:~s" (gethash *errors* code)))
; Get rid of this... Maybe

(defparameter output-opcodes? nil)

(defun output-opcodes (value)
    (if (not (null value))
        (setf output-opcodes? t)
        (setf output-opcodes?`nil)))

(defun outputdata()
    (format t "~a" (code-char (aref *tape* *position*))))

(defun readindata()
    (force-output *query-io*)
    (setf (aref *tape* *position*) (char-code (elt (string (read)) 0)))) ;only uppercase. bummer. I can't get READ-LINE to work in LispIDE >:c

(defun turn-literal-input (literal-input)
    (coerce literal-input 'list)
)

(defun bf(userinput)
  (setf userinput (turn-literal-input userinput))
   (loop
        (if (not (< *userposition* (length userinput)))
            (return))
        (cond   ((equal (nth *userposition* userinput) #\+)
                    (incf (aref *tape* *position*))
                    (if output-opcodes? (format t "OP1;")))
                ((equal (nth *userposition* userinput) #\-)
                    (if (eql 0 (aref *tape* *position*))
                        (return)
                        (decf (aref *tape* *position*)))
                    (if output-opcodes? (format t "OP2;")))
                ((equal (nth *userposition* userinput) #\>)
                    (if (eql *position* (1- (length *tape*)))
                        (setf *position* 0)
                        (incf *position*))
                    (if output-opcodes? (format t "OP3;")))
                ((equal (nth *userposition* userinput) #\<)
                    (if (eql 0 *position*)
                        (setf *position* (1- (length *tape*)))
                        (decf *position*))
                    (if output-opcodes? (format t "OP4;")))
                ((equal (nth *userposition* userinput) #\.)
                    (outputdata)
                    (if output-opcodes? (format t "OP5;")))
                ((equal (nth *userposition* userinput) #\,)
                    (readindata)
                    (if output-opcodes? (format t "OP6;")))
                ((equal (nth *userposition* userinput) #\!)
                    (return)
                    (if output-opcodes? (format t "OP7;")))
                ((equal (nth *userposition* userinput) #\[)
                    (if output-opcodes? (format t "OP8;"))
                    (incf *openbracket-appear*)
                    (if (eql (aref *tape* *position*) 0)
                        (loop
                            (if (equal (nth *userposition* userinput) #\])
                                    (progn (incf loopforward-appear)
                                           (if (equal loopforward-appear *openbracket-appear*)
                                               (progn (if (not (eql *userposition* (1- (length userinput))))
                                                            (incf *userposition*))
                                                      (return)))))
                            (incf *userposition*))))
                ((equal (nth *userposition* userinput) #\])
                    (if output-opcodes? (format t "OP9;"))
                    ;;Oh dear
                    (incf *closebracket-appear*)
                    (if (not (eql (aref *tape* *position*) 0))
                        (loop
                            (cond ((equal (nth *userposition* userinput) #\[)
                                    (incf loopback-appear)
                                    (if (eql loopback-appear *closebracket-appear*)
                                            (return))))
                            (decf *userposition*)))))
        (incf *userposition*)
    )
    (if output-opcodes? (format t "EOF;;"))
    (setf *userposition* 0 *openbracket-appear* 0 *closebracket-appear* 0 loopback-appear 0 loopforward-appear 0)
  *tape*
)