;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.brainfuck)

;;;;;;
;;; Abstract syntax

(def class* brainfuck-program ()
  ((commands nil :type list)))

(def class* command ()
  ((program :type brainfuck-program)
   (previous-command nil :type (or null command))
   (next-command nil :type (or null command))))

(def class* pointer-increment-command (command)
  ())

(def class* pointer-decrement-command (command)
  ())

(def class* value-increment-command (command)
  ())

(def class* value-decrement-command (command)
  ())

(def class* value-output-command (command)
  ())

(def class* value-input-command (command)
  ())

(def class* conditional-block-begin-command (command)
  ((pair-command nil :type (or null conditional-block-end-command))))

(def class* conditional-block-end-command (command)
  ((pair-command nil :type (or null conditional-block-begin-command))))

;;;;;;
;;; Reader

(def (function e) read-program (input)
  (if (stringp input)
      (with-input-from-string (stream input)
        (read-program stream))
      (prog1-bind program (make-instance 'brainfuck-program)
        (iter (for character = (read-char input nil input))
              (until (eq character input))
              (awhen (ast-node-class-name character)
                (push (make-instance it) (commands-of program)))
              (finally
                (setf (commands-of program) (nreverse (commands-of program)))
                (finalize-program program))))))

(def function ast-node-class-name (character)
  (case character
    (#\> 'pointer-increment-command)
    (#\< 'pointer-decrement-command)
    (#\+ 'value-increment-command)
    (#\- 'value-decrement-command)
    (#\. 'value-output-command)
    (#\, 'value-input-command)
    (#\[ 'conditional-block-begin-command)
    (#\] 'conditional-block-end-command)))

(def function finalize-program (program)
  (iter (with commands = (commands-of program))
        (for position :from 0)
        (for command :in-sequence commands)
        (for previous-command :previous command)
        (setf (program-of command) program)
        (when previous-command
          (setf (next-command-of previous-command) command)
          (setf (previous-command-of command) previous-command))
        (when (typep command '(or conditional-block-begin-command conditional-block-end-command))
          (unless (pair-command-of command)
            (bind ((pair-command (elt commands (conditional-block-pair-position program position (etypecase command
                                                                                                   (conditional-block-begin-command :forward)
                                                                                                   (conditional-block-end-command :backward))))))
              (setf (pair-command-of command) pair-command)
              (setf (pair-command-of pair-command) command))))))

(def function conditional-block-pair-position (program start direction)
  (iter (with depth = 0)
        (with commands = (commands-of program))
        (for position :initially start :then (+ position (ecase direction
                                                           (:forward 1)
                                                           (:backward -1))))
        (unless (<= 0 position (1- (length commands)))
          (error "Cannot find condition block pair"))
        (for command = (elt commands position))
        (typecase command
          (conditional-block-begin-command
           (incf depth))
          (conditional-block-end-command
           (decf depth)))
        (when (and (zerop depth)
                   (ecase direction
                     (:forward (typep command 'conditional-block-end-command))
                     (:backward (typep command 'conditional-block-begin-command))))
          (return position))))

;;;;;;
;;; Printer

(def (function e) print-program (program &key output)
  (if (null output)
      (with-output-to-string (output)
        (print-program program :output output))
      (iter (for command :in-sequence (commands-of program))
            (print-ast-node command output))))

(def generic print-ast-node (command stream)
  (:method ((command pointer-increment-command) stream)
    (write-char #\> stream))

  (:method ((command pointer-decrement-command) stream)
    (write-char #\< stream))

  (:method ((command value-increment-command) stream)
    (write-char #\+ stream))

  (:method ((command value-decrement-command) stream)
    (write-char #\- stream))

  (:method ((command value-output-command) stream)
    (write-char #\. stream))

  (:method ((command value-input-command) stream)
    (write-char #\, stream))

  (:method ((command conditional-block-begin-command) stream)
    (write-char #\[ stream))

  (:method ((command conditional-block-end-command) stream)
    (write-char #\] stream)))

;;;;;;
;;; Evaluator

(def (special-variable e) *default-evaluation-mode* :interpreter)

(def (function e) evaluate-program (program &key input output (evalation-mode *default-evaluation-mode*))
  (if (eq evalation-mode :interpreter)
      (interpret-program program :input input :output output)
      (funcall (assemble-program (compile-program program)) input output)))

(def function make-memory ()
  (make-array (expt 2 16) :element-type '(unsigned-byte 8)))

;;;;;;
;;; Interpreter

(def class* interpreter ()
  ((input :type stream)
   (output :type stream)
   (memory :type (simple-array (unsigned-byte 8)))
   (memory-pointer :type integer)
   (current-command :type command)))

(def (function e) interpret-program (program &key input output)
  (cond ((arrayp input)
         (flexi-streams:with-input-from-sequence (stream input)
           (%interpret-program program :input stream)))
        ((null output)
         (flexi-streams:with-output-to-sequence (stream)
           (%interpret-program program :input input :output stream)
           output))
        (t
         (%interpret-program program :input input :output output))))

(def function %interpret-program (program &key input output)
  (iter (with interpreter = (make-interpreter program input output))
        (for current-command = (current-command-of interpreter))
        (while current-command)
        (interpret-command interpreter current-command)))

(def function make-interpreter (program input output)
  (make-instance 'interpreter
                 :input input
                 :output output
                 :memory (make-memory)
                 :memory-pointer 0
                 :current-command (first (commands-of program))))

(def generic interpret-command (interpreter command)
  (:method ((interpreter interpreter) (command pointer-increment-command))
    (bind (((:slots memory-pointer memory current-command) interpreter))
      (when (= memory-pointer (1- (length memory)))
        (error "Cannot move memory pointer outside of memory"))
      (incf memory-pointer)
      (setf current-command (next-command-of current-command))))

  (:method ((interpreter interpreter) (command pointer-decrement-command))
    (bind (((:slots memory-pointer memory current-command) interpreter))
      (when (zerop memory-pointer)
        (error "Cannot move memory pointer outside of memory"))
      (decf memory-pointer)
      (setf current-command (next-command-of current-command))))

  (:method ((interpreter interpreter) (command value-increment-command))
    (bind (((:slots memory-pointer memory current-command) interpreter))
      (setf (aref memory memory-pointer) (mod (1+ (aref memory memory-pointer)) 256))
      (setf current-command (next-command-of current-command))))

  (:method ((interpreter interpreter) (command value-decrement-command))
    (bind (((:slots memory-pointer memory current-command) interpreter))
      (setf (aref memory memory-pointer) (mod (1- (aref memory memory-pointer)) 256))
      (setf current-command (next-command-of current-command))))

  (:method ((interpreter interpreter) (command value-output-command))
    (bind (((:slots memory-pointer memory output current-command) interpreter))
      (write-byte (aref memory memory-pointer) output)
      (setf current-command (next-command-of current-command))))

  (:method ((interpreter interpreter) (command value-input-command))
    (bind (((:slots memory-pointer memory input current-command) interpreter))
      (setf (aref memory memory-pointer) (read-byte input))
      (setf current-command (next-command-of current-command))))

  (:method ((interpreter interpreter) (command conditional-block-begin-command))
    (bind (((:slots memory-pointer memory current-command) interpreter))
      (setf current-command (next-command-of (if (zerop (aref memory memory-pointer))
                                                 (pair-command-of command)
                                                 current-command)))))

  (:method ((interpreter interpreter) (command conditional-block-end-command))
    (bind (((:slots memory-pointer memory current-command) interpreter))
      (setf current-command (next-command-of (if (zerop (aref memory memory-pointer))
                                                 current-command
                                                 (pair-command-of command)))))))

;;;;;;
;;; Assembly

(def class* assembly-program ()
  ((instructions nil :type list)))

(def class* instruction ()
  ())

(def class* size-mixin ()
  ((size :type (member :byte :word :double-word))))

(def class* unary-instruction ()
  ((operand)))

(def class* binary-instruction ()
  ((first-operand)
   (second-operand)))

(def class* inc-instruction (unary-instruction size-mixin)
  ())

(def class* dec-instruction (unary-instruction size-mixin)
  ())

(def class* int-instruction (unary-instruction)
  ())

(def class* push-instruction (unary-instruction)
  ())

(def class* pop-instruction (unary-instruction)
  ())

(def class* add-instruction (binary-instruction size-mixin)
  ())

(def class* sub-instruction (binary-instruction size-mixin)
  ())

(def class* mov-instruction (binary-instruction size-mixin)
  ())

(def class* cmp-instruction (binary-instruction size-mixin)
  ())

(def class* jz-instruction ()
  ((label)))

(def class* jnz-instruction ()
  ((label)))

(def class* label-instruction ()
  ())

(def class* operand ()
  ())

(def class* immediate-operand (operand)
  ((value)))

(def class* register-operand (operand)
  ((name)))

(def class* memory-location-operand (operand size-mixin)
  ((segment)
   (offset)
   (base)
   (index)
   (scale)))

;;;;;;
;;; Compiler

(def class* compiler ()
  ((command-labels (make-hash-table :test #'equal) :type hash-table)))

(def (function e) compile-program (program)
  (bind ((compiler (make-compiler)))
    (make-instance 'assembly-program
                   :instructions (iter (for command :in (commands-of program))
                                       (appending (compile-command compiler command))))))

(def function make-compiler ()
  (make-instance 'compiler))

(def generic compile-command (compiler command)
  (:method ((compiler compiler) (command pointer-increment-command))
    (list (make-instance 'inc-instruction
                         :size :double-word
                         :operand (make-instance 'register-operand :name :r8))))

  (:method ((compiler compiler) (command pointer-decrement-command))
    (list (make-instance 'dec-instruction
                         :size :double-word
                         :operand (make-instance 'register-operand :name :r8))))

  (:method ((compiler compiler) (command value-increment-command))
    (list (make-instance 'inc-instruction
                         :size :byte
                         :operand (make-instance 'memory-location-operand
                                                 :size :byte
                                                 :segment (make-instance 'register-operand :name :r8)
                                                 :offset 0
                                                 :base 0
                                                 :index 0
                                                 :scale (make-instance 'register-operand :name :r8)))))

  (:method ((compiler compiler) (command value-decrement-command))
    (list (make-instance 'dec-instruction
                         :size :byte
                         :operand (make-instance 'memory-location-operand
                                                 :size :byte
                                                 :segment (make-instance 'register-operand :name :r8)
                                                 :offset 0
                                                 :base 0
                                                 :index 0
                                                 :scale (make-instance 'register-operand :name :r8)))))

  (:method ((compiler compiler) (command value-output-command))
    (list (make-instance 'mov-instruction
                         :first-operand (make-instance 'register-operand :name :rax)
                         :second-operand (make-instance 'immediate-operand :value 4))
          (make-instance 'mov-instruction
                         :first-operand (make-instance 'register-operand :name :rbx)
                         :second-operand (make-instance 'immediate-operand :value 1))
          (make-instance 'mov-instruction
                         :first-operand (make-instance 'register-operand :name :rcx)
                         :second-operand (make-instance 'register-operand :name :r8))
          (make-instance 'mov-instruction
                         :first-operand (make-instance 'register-operand :name :rdx)
                         :second-operand (make-instance 'immediate-operand :value 1))
          (make-instance 'push-instruction
                         :operand (make-instance 'register-operand :name :r8))
          (make-instance 'int-instruction
                         :operand (make-instance 'immediate-operand :value #x80))
          (make-instance 'pop-instruction
                         :operand (make-instance 'register-operand :name :r8))))

  (:method ((compiler compiler) (command value-input-command))
    ;; TODO:
    (list ))

  (:method ((compiler compiler) (command conditional-block-begin-command))
    (list (make-instance 'cmp-instruction
                         :size :byte
                         :first-operand (make-instance 'memory-location-operand
                                                       :size :byte
                                                       :segment (make-instance 'register-operand :name :r8)
                                                       :offset 0
                                                       :base 0
                                                       :index 0
                                                       :scale (make-instance 'register-operand :name :r8))
                         :second-operand (make-instance 'immediate-operand :value 0))
          (make-instance 'jz-instruction :label (ensure-command-label compiler (pair-command-of command)))
          (ensure-command-label compiler command)))

  (:method ((compiler compiler) (command conditional-block-end-command))
    (list (make-instance 'cmp-instruction
                         :size :byte
                         :first-operand (make-instance 'memory-location-operand
                                                       :size :byte
                                                       :segment (make-instance 'register-operand :name :r8)
                                                       :offset 0
                                                       :base 0
                                                       :index 0
                                                       :scale (make-instance 'register-operand :name :r8))
                         :second-operand (make-instance 'immediate-operand :value 0))
          (make-instance 'jnz-instruction :label (ensure-command-label compiler (pair-command-of command)))
          (ensure-command-label compiler command))))

(def function ensure-command-label (compiler command)
  (or (gethash command (command-labels-of compiler))
      (setf (gethash command (command-labels-of compiler)) (make-instance 'label-instruction))))

;;;;;;
;;; Optimizer

(def (function e) optimize-program (program)
  (split-sequence-by-partitioning (instructions-of program)
                                  (lambda (instruction)
                                    (print(and (typep instruction 'inc-instruction)
                                          (typep (operand-of instruction) 'register-operand)
                                          (eq (name-of (operand-of instruction)) :r8))))
                                  (lambda (instruction)
                                    (not (and (typep instruction 'inc-instruction)
                                          (typep (operand-of instruction) 'register-operand)
                                          (eq (name-of (operand-of instruction)) :r8))))))

;;;;;;
;;; Nasm

;; TODO: dispatch on assembler
(def class* nasm-assembler ()
  ((instruction-labels (make-hash-table :test #'equal) :type hash-table)))

(def (function e) print-nasm (program stream)
  (write-string "BITS 64
section .data
	memory:     db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
global _start
_start: mov r8, memory" stream)
  (iter (with assembler = (make-instance 'nasm-assembler))
        (for instruction :in (instructions-of program))
        (format stream "~%	~A" (print-instruction assembler instruction)))
  (write-string "
	mov eax, 1
	mov ebx, 0
	int 80h" stream)
  (values))

(def generic print-instruction (assembler instruction)
  (:method ((assembler nasm-assembler) (instruction label-instruction))
    (format nil "~%~A:" (ensure-instruction-label2 assembler instruction)))

  (:method ((assembler nasm-assembler) (instruction inc-instruction))
    (format nil "inc ~A" (print-operand assembler (operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction dec-instruction))
    (format nil "dec ~A" (print-operand assembler (operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction int-instruction))
    (format nil "int ~A" (print-operand assembler (operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction push-instruction))
    (format nil "push ~A" (print-operand assembler (operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction pop-instruction))
    (format nil "pop ~A" (print-operand assembler (operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction mov-instruction))
    (format nil "mov ~A, ~A" (print-operand assembler (first-operand-of instruction)) (print-operand assembler (second-operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction cmp-instruction))
    (format nil "cmp ~A, ~A" (print-operand assembler (first-operand-of instruction)) (print-operand assembler (second-operand-of instruction))))

  (:method ((assembler nasm-assembler) (instruction jz-instruction))
    (format nil "jz ~A" (print-operand assembler (label-of instruction))))

  (:method ((assembler nasm-assembler) (instruction jnz-instruction))
    (format nil "jnz ~A" (print-operand assembler (label-of instruction)))))

(def generic print-operand (assembler location)
  (:method ((assembler nasm-assembler) (operand label-instruction))
    (ensure-instruction-label2 assembler operand))

  (:method ((assembler nasm-assembler) (operand immediate-operand))
    (princ-to-string (value-of operand)))

  (:method ((assembler nasm-assembler) (operand register-operand))
    (string-downcase (name-of operand)))

  (:method ((assembler nasm-assembler) (operand memory-location-operand))
    (format nil "byte [~A]" (print-operand assembler (segment-of operand)))))

(def function ensure-instruction-label2 (assembler instruction)
  (or (gethash instruction (instruction-labels-of assembler))
      (setf (gethash instruction (instruction-labels-of assembler)) (string-downcase (gensym)))))

;;;;;;
;;; Assembler

;; TODO: use literal array of bytes and encode instructions

(def class* assembler ()
  ((instruction-labels (make-hash-table :test #'equal) :type hash-table)))

(def (function e) assemble-program (program)
  (bind ((assembler (make-assembler)))
    (eval `(sb-c:define-vop (brainfuck)
             (:args (memory :scs (sb-vm::descriptor-reg))
                    (input :scs (sb-vm::descriptor-reg))
                    (output :scs (sb-vm::descriptor-reg)))
             (:note "Brainfuck program")
             (:generator 1
               ;; KLUDGE: this overwrites rax
               (sb-assem:inst push sb-vm::r8-tn)
               (sb-assem:inst mov sb-vm::r8-tn memory)
               ,@(iter (for instruction :in (instructions-of program))
                       (collect (assemble-instruction assembler instruction)))
               (sb-assem:inst pop sb-vm::r8-tn))))
    (bind ((internal (compile nil '(lambda (memory input output)
                                     (declare (optimize (speed 3) (debug 0) (safety 0)))
                                     (sb-sys:%primitive brainfuck memory input output)
                                     output)))
           (external (compile nil `(lambda (input)
                                     (declare (optimize (speed 3) (debug 0) (safety 0)))
                                     (flexi-streams:with-output-to-sequence (output)
                                       (cffi:with-pointer-to-vector-data (pointer (make-memory))
                                         (funcall ,internal pointer input output)))))))
      (values external internal))))

(def function make-assembler ()
  (make-instance 'assembler))

(def generic assemble-instruction (assembler instruction)
  (:method ((assembler assembler) (instruction label-instruction))
    `(sb-assem::emit-label ,(ensure-instruction-label assembler instruction)))

  (:method ((assembler assembler) (instruction inc-instruction))
    `(sb-assem:inst inc ,(assemble-operand assembler (operand-of instruction))))

  (:method ((assembler assembler) (instruction dec-instruction))
    `(sb-assem:inst dec ,(assemble-operand assembler (operand-of instruction))))

  (:method ((assembler assembler) (instruction int-instruction))
    `(sb-assem:inst int ,(assemble-operand assembler (operand-of instruction))))

  (:method ((assembler assembler) (instruction push-instruction))
    `(sb-assem:inst push ,(assemble-operand assembler (operand-of instruction))))

  (:method ((assembler assembler) (instruction pop-instruction))
    `(sb-assem:inst pop ,(assemble-operand assembler (operand-of instruction))))

  (:method ((assembler assembler) (instruction mov-instruction))
    `(sb-assem:inst mov
                    ,(assemble-operand assembler (first-operand-of instruction))
                    ,(assemble-operand assembler (second-operand-of instruction))))

  (:method ((assembler assembler) (instruction cmp-instruction))
    `(sb-assem:inst cmp
                    ,(assemble-operand assembler (first-operand-of instruction))
                    ,(assemble-operand assembler (second-operand-of instruction))))

  (:method ((assembler assembler) (instruction jz-instruction))
    `(sb-assem:inst jmp :z ,(assemble-operand assembler (label-of instruction))))

  (:method ((assembler assembler) (instruction jnz-instruction))
    `(sb-assem:inst jmp :nz ,(assemble-operand assembler (label-of instruction)))))

(def generic assemble-operand (assembler location)
  (:method ((assembler assembler) (operand label-instruction))
    (ensure-instruction-label assembler operand))

  (:method ((assembler assembler) (operand immediate-operand))
    (value-of operand))

  (:method ((assembler assembler) (operand register-operand))
    (ecase (name-of operand)
      (:rax sb-vm::rax-tn)
      (:rbx sb-vm::rbx-tn)
      (:rcx sb-vm::rcx-tn)
      (:rdx sb-vm::rdx-tn)
      (:r8 sb-vm::r8-tn)
      (:r9 sb-vm::r9-tn)
      (:r10 sb-vm::r10-tn)
      (:r11 sb-vm::r11-tn)
      (:r12 sb-vm::r12-tn)
      (:r13 sb-vm::r13-tn)
      (:r14 sb-vm::r14-tn)
      (:r15 sb-vm::r15-tn)))

  (:method ((assembler assembler) (operand memory-location-operand))
    (sb-vm::make-ea (size-of operand) :base (assemble-operand assembler (segment-of operand)))))

(def function ensure-instruction-label (assembler instruction)
  (or (gethash instruction (instruction-labels-of assembler))
      (setf (gethash instruction (instruction-labels-of assembler)) (sb-assem::gen-label))))

;;;;;;
;;; Builder

(def (function e) build-program (program output-file)
  (declare (ignore program output-file))
  (not-yet-implemented/crucial-api))

;;;;;;
;;; Executable

(def constant +program-command-line-option+
  '(("program" #\p)
    :type string
    :optional #t
    :documentation "Provides the brainfuck program as a literal command line argument."))

(def constant +program-file-command-line-option+
  '(("input-file" #\i)
    :type string
    :optional #t
    :documentation "Provides the brainfuck program in a separate file."))

(def constant +build-command-line-option+
  '(("build" #\b)
    :type boolean
    :optional #t
    :documentation "Builds a standalone executable from the provided brainfuck program."))

(def constant +build-output-file-command-line-option+
  '(("output-file" #\o)
    :type string
    :optional #t
    :documentation "The output file name for building an executable brainfuck program."))

(def constant +evaluate-command-line-option+
  '(("evaluate" #\e)
    :type boolean
    :initial-value #t
    :documentation "Evaluates the provided brainfuck program using the specified evaluation mode."))

(def constant +evaluation-mode-command-line-option+
  '(("evaluation-mode" #\m)
    :type string
    :initial-value "interpreter"
    :documentation "Specifies the evaluation mode for the evaluate option, either use interpreter or compiler."))

(def (function e) executable-toplevel ()
  (with-standard-toplevel-restarts
    (bind ((options (list +help-command-line-option+
                          +program-command-line-option+
                          +program-file-command-line-option+
                          +build-command-line-option+
                          +build-output-file-command-line-option+
                          +evaluate-command-line-option+
                          +evaluation-mode-command-line-option+))
           (arguments (process-command-line-options options (get-command-line-arguments))))
      (disable-debugger)
      (process-help-command-line-argument options arguments)
      (bind ((program (or (getf arguments :program)
                          (read-file-into-string (getf arguments :input-file))))
             (evaluation-mode (getf arguments :evaluation-mode)))
        (cond ((getf arguments :build)
               (build-program (read-program program) (getf arguments :output-file)))
              ((and (getf arguments :evaluate)
                    (equalp evaluation-mode "interpreter"))
               (interpret-program (read-program program) :input *standard-input* :output *standard-output*))
              ((and (getf arguments :evaluate)
                    (equalp evaluation-mode "compiler"))
               (funcall (assemble-program (compile-program (read-program program))) *standard-input* *standard-output*))
              (t
               (command-line-arguments:show-option-help options)
               (quit -1)))
        +no-error-status-code+))))