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

(in-package :hu.dwim.excosy)

;;;;;;
;;; Abstract syntax

(def class* brainfuck-program (ast)
  ((commands nil :type list)
   (interpreter-function 'interpret-brainfuck-program)))

(def function interpret-brainfuck-program (machine ast)
  (bind ((pointer-register (llvm/generate-new-register-name :pointer)))
    (llvm/malloc machine (llvm/register machine "memory") (llvm/type machine :signed-integer 8) (llvm/type machine :signed-integer 32) 65536)
    (llvm/call machine nil (llvm/type machine :void) "llvm.memset.i32"
               (llvm/type machine :signed-integer 8 1) (llvm/register machine "memory") (llvm/type machine :signed-integer 8) 0 (llvm/type machine :signed-integer 32) 65536 (llvm/type machine :signed-integer 32) 1)
    (llvm/getelementptr machine (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine "memory") (llvm/type machine :signed-integer 32) 32768)
    (llvm/alloca machine (llvm/register machine "pointer") (llvm/type machine :signed-integer 8 1) 1)
    (llvm/store machine (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (set-current-special-form (runtime-state-of machine) (first (commands-of ast)))
    #+nil(set-continuation (lambda () (set-current-special-form (runtime-state-of machine) (first (commands-of ast)))))
    #+nil (llvm/unconditional-br machine (labello first commands))
    #+nil (set-continuation (runtime-state-of machine) (lambda ()))
    #+nil (throw :go-to-current-special-form)
    (llvm/free machine (llvm/type machine :signed-integer 8 1) (llvm/register machine "memory"))
    nil))

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

(def class* pointer-increment-command (command)
  ((interpreter-function 'interpret-pointer-increment-command)))

(def function interpret-pointer-change-command (machine ast delta)
  (bind ((oldpointer-register (llvm/generate-new-register-name :newpointer))
         (pointer-oldvalue-register (llvm/generate-new-register-name :pointer-old-value))
         (pointer-newvalue-register (llvm/generate-new-register-name :pointer-new-value))
         (newpointer-register (llvm/generate-new-register-name :newpointer))
         (bit-size (word-bit-size-of (configuration-of machine))))
    (llvm/load machine (llvm/register machine oldpointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (llvm/ptrtoint machine (llvm/register machine pointer-oldvalue-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine oldpointer-register) (llvm/type machine :signed-integer bit-size))
    (llvm/add machine (llvm/register machine pointer-newvalue-register) (llvm/type machine :signed-integer bit-size) (llvm/register machine pointer-oldvalue-register) delta)
    (llvm/inttoptr machine (llvm/register machine newpointer-register) (llvm/type machine :signed-integer bit-size) (llvm/register machine pointer-newvalue-register) (llvm/type machine :signed-integer 8 1))
    (llvm/store machine (llvm/type machine :signed-integer 8 1) (llvm/register machine newpointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (set-current-special-form (runtime-state-of machine) (next-command-of ast))
    nil))

(def function interpret-pointer-increment-command (machine ast)
  (interpret-pointer-change-command machine ast 1))

(def class* pointer-decrement-command (command)
  ((interpreter-function 'interpret-pointer-decrement-command)))

(def function interpret-pointer-decrement-command (machine ast)
  (interpret-pointer-change-command machine ast -1))

(def class* value-increment-command (command)
  ((interpreter-function 'interpret-value-increment-command)))

(def function interpret-value-change-command (machine ast delta)
  (bind ((pointer-register (llvm/generate-new-register-name :value))
         (value-register (llvm/generate-new-register-name :value))
         (incremented-value-register (llvm/generate-new-register-name :incremented-value)))
    (llvm/load machine (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (llvm/load machine (llvm/register machine value-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register))
    (llvm/add machine (llvm/register machine incremented-value-register) (llvm/type machine :signed-integer 8) (llvm/register machine value-register) delta)
    (llvm/store machine (llvm/type machine :signed-integer 8) (llvm/register machine incremented-value-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register))
    (set-current-special-form (runtime-state-of machine) (next-command-of ast))
    nil))

(def function interpret-value-increment-command (machine ast)
  (interpret-value-change-command machine ast 1))

(def class* value-decrement-command (command)
  ((interpreter-function 'interpret-value-decrement-command)))

(def function interpret-value-decrement-command (machine ast)
  (interpret-value-change-command machine ast -1))

(def class* value-output-command (command)
  ((interpreter-function 'interpret-value-output-command)))

(def function interpret-value-output-command (machine ast)
  (bind ((pointer-register (llvm/generate-new-register-name :pointer))
         (value-register (llvm/generate-new-register-name :value))
         (argument-register (llvm/generate-new-register-name :argument))
         (bit-size (word-bit-size-of (configuration-of machine)))
         (putchar "putchar"))
    (llvm/declare machine (llvm/type machine :signed-integer bit-size) putchar (llvm/type machine :signed-integer bit-size))
    (llvm/load machine (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (llvm/load machine (llvm/register machine value-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register))
    (llvm/zext machine (llvm/register machine argument-register) (llvm/type machine :signed-integer 8) (llvm/register machine value-register) (llvm/type machine :signed-integer bit-size))
    (llvm/call machine nil (llvm/type machine :signed-integer bit-size) putchar (llvm/type machine :signed-integer bit-size) (llvm/register machine argument-register))
    (set-current-special-form (runtime-state-of machine) (next-command-of ast))
    nil))

(def class* value-input-command (command)
  ((interpreter-function 'interpret-value-input-command)))

(def function interpret-value-input-command (machine ast)
  (bind ((pointer-register (llvm/generate-new-register-name :pointer))
         (value-register (llvm/generate-new-register-name :value))
         (truncated-value-register (llvm/generate-new-register-name :trunced-value))
         (bit-size (word-bit-size-of (configuration-of machine)))
         (getchar "getchar"))
    (llvm/declare machine (llvm/type machine :signed-integer bit-size) getchar)
    (llvm/load machine (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (llvm/call machine (llvm/register machine value-register) (llvm/type machine :signed-integer bit-size) getchar)
    (llvm/trunc machine (llvm/register machine truncated-value-register) (llvm/type machine :signed-integer 32) (llvm/register machine value-register) (llvm/type machine :signed-integer 8))
    (llvm/store machine (llvm/type machine :signed-integer 8) (llvm/register machine truncated-value-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register))
    (set-current-special-form (runtime-state-of machine) (next-command-of ast))
    nil))

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

(def function interpret-conditional-block-begin-command (machine ast)
  (bind ((pointer-register (llvm/generate-new-register-name :pointer))
         (value-register (llvm/generate-new-register-name :value))
         (comparison-result-register (llvm/generate-new-register-name :comparison-result))
         (bit-size (word-bit-size-of (configuration-of machine))))
    (llvm/load machine (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (llvm/load machine (llvm/register machine value-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register))
    (llvm/icmp machine (llvm/register machine comparison-result-register) :llvm/eq (llvm/type machine :signed-integer bit-size)
               (llvm/register machine value-register) 0)
    (llvm/conditional-br machine (llvm/register machine comparison-result-register) (llvm/label-reference machine :pair-command) (llvm/label-reference machine :this-command))
    (llvm/label machine :this-command)
    (set-current-special-form (runtime-state-of machine) (next-command-of ast))
    nil))

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

(def function interpret-conditional-block-end-command (machine ast)
  (bind ((pointer-register (llvm/generate-new-register-name :pointer))
         (value-register (llvm/generate-new-register-name :value))
         (comparison-result-register (llvm/generate-new-register-name :comparison-result))
         (bit-size (word-bit-size-of (configuration-of machine))))
    (llvm/load machine (llvm/register machine pointer-register) (llvm/type machine :signed-integer 8 2) (llvm/register machine "pointer"))
    (llvm/load machine (llvm/register machine value-register) (llvm/type machine :signed-integer 8 1) (llvm/register machine pointer-register))
    (llvm/icmp machine (llvm/register machine comparison-result-register) :llvm/neq (llvm/type machine :signed-integer bit-size)
               (llvm/register machine value-register) 0)
    (llvm/conditional-br machine (llvm/register machine comparison-result-register) (llvm/label-reference machine :pair-command) (llvm/label-reference machine :this-command))
    (llvm/label machine :this-command)
    (set-current-special-form (runtime-state-of machine) (next-command-of ast))
    nil))

;;;;;;
;;; Reader

(def (function e) read-brainfuck-program (input)
  (if (stringp input)
      (with-input-from-string (stream input)
        (read-brainfuck-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-brainfuck-program (program &key output)
  (if (null output)
      (with-output-to-string (output)
        (print-brainfuck-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)))