brainfuck compiler written in Common Lisp (SBCL)

brainfuck.lisp

#!/usr/bin/sbcl --script
;;; brainfuck compiler written in Common Lisp (SBCL)
;;; author: TANI Kojiro
;;; usage: `sbcl --script brainfuck.lisp` or `chmod +x brainfuck.lisp; ./brainfuck.lisp`

(declaim ((simple-array (unsigned-byte 8) (*)) *memory*))
(defvar *memory* (make-array 30000 :element-type '(unsigned-byte 8)))
(defvar *pointer* 0)
(defvar *bf-readtable* (make-instance 'readtable))

(defun count-positive-and-negative-chars (positive-char negative-char stream char)
  (let ((chars (loop :for char := (read-char stream nil)
                     :while (find char `(,positive-char ,negative-char)) :collect char
                     :finally (unread-char char stream))))
    (- (count positive-char chars)
       (count negative-char chars)
       (if (char= char negative-char) 1 -1))))

(defun plus-minus-reader (stream char)
  `(incf (aref *memory* *pointer*) ,(count-positive-and-negative-chars #\+ #\- stream char)))

(defun gt-lt-reader (stream char)
  `(incf *pointer* ,(count-positive-and-negative-chars #\> #\< stream char)))

(defun comma-reader (stream char)
  (declare (ignore stream char))
  '(setf (aref *memory* *pointer*) (char-code (read-char *standard-input*))))

(defun dot-reader (stream char)
  (declare (ignore stream char))
  '(princ (code-char (aref *memory* *pointer*))))

(defun openparen-reader (stream char)
  (declare (ignore char))
  (let ((body (loop :for form := (read stream t)
                    :until (eql form ']) :collect form)))
    `(loop :until (zerop (aref *memory* *pointer*))
           :do (progn ,@body))))

(defun closeparen-reader (stream char)
  (declare (ignore char))
  '])

(defun newline-reader (stream char)
  (declare (ignore stream char))
  't)

(set-macro-character #\+ #'plus-minus-reader nil *bf-readtable*)
(set-macro-character #\- #'plus-minus-reader nil *bf-readtable*)
(set-macro-character #\> #'gt-lt-reader nil *bf-readtable*)
(set-macro-character #\< #'gt-lt-reader nil *bf-readtable*)
(set-macro-character #\, #'comma-reader  nil *bf-readtable*)
(set-macro-character #\. #'dot-reader  nil *bf-readtable*)
(set-macro-character #\[ #'openparen-reader nil *bf-readtable*)
(set-macro-character #\] #'closeparen-reader nil *bf-readtable*)
(set-macro-character #\newline #'newline-reader nil *bf-readtable*)
(set-macro-character #\; (get-macro-character #\;) nil *bf-readtable*)

(defmacro with-simple-handler (&body body)
  `(handler-case
     (let ((*error-output* (make-broadcast-stream))) ,@body)
     (condition (c) (format t "~&~a~%" c))))

(defun execute-brainfuck (file)
  (with-simple-handler
    (let ((*readtable* *bf-readtable*))
      (load file))))

(defun compile-brainfuck (input output)
  (let ((toplevel-forms))
    (with-open-file (stream input :direction :input)
      (let ((*readtable* *bf-readtable*))
        (setf toplevel-forms
              `(with-simple-handler ,@(loop :for form := (read stream nil)
                                            :while form :collect form)))))
    (save-lisp-and-die output
                       :toplevel (lambda () (eval toplevel-forms))
                       :executable t
                       :purify t)))

(defun show-usage-and-exit ()
  (format t "Usage: ~a~@[.~a~] input [-c|[-o output]]~%"
          (pathname-name *load-truename*)
          (pathname-type *load-truename*))
  (exit))

(defun main ()
  (let ((input (cadr *posix-argv*))
        (output) (compile-p))
    (let ((pos (position "-o" *posix-argv* :test #'string=)))
      (setf output (if pos  (nth (1+ pos) *posix-argv*) "a.out")))
    (setf compile-p (find "-c" *posix-argv* :test #'string=))
    (unless input (show-usage-and-exit))
    (if compile-p
        (compile-brainfuck input output)
        (execute-brainfuck input))))

(main)