(in-package #:cl-user)
(defpackage #:cradle
  (:use #:cl)
  (:export))
(in-package #:cradle)

;; Parameters

(defparameter *indentation* 8)

(defparameter *line-length* 80)

(defparameter *value-length* 8)

;; Cradle

(defclass cradle ()
  ((line-buffer :initform (make-array *line-length*
                                      :element-type 'base-char
                                      :fill-pointer 0)
                :reader line-buffer)
   (value-buffer :initform (make-array *value-length*
                                       :element-type 'base-char
                                       :fill-pointer 0)
                 :reader value-buffer)
   (look :initform #\Nul :type base-char :accessor look)
   (input :initform NIL :accessor input)
   (output :initform NIL :accessor output)))

(defmethod initialize-instance :after ((cradle cradle) &key input output)
  (setf (input cradle) (etypecase input
                         (stream input)
                         (pathname (open input :direction :input
                                               :if-does-not-exist :error))
                         (null *standard-input*)))
  (setf (output cradle) (etypecase output
                          (stream output)
                          (pathname (open output :direction :output
                                                 :if-does-not-exist :create))
                          (null *standard-output*)))
  (emit-line cradle ".text")
  (emit-line cradle ".globl main")
  (emit-line cradle)
  (emit-label cradle "main")
  (emit-line cradle)
  (get-char cradle)
  (skip-space cradle))

(defmethod finalize ((cradle cradle))
  (unless (eql *standard-input* (input cradle))
    (close (input cradle)))
  (unless (eql *standard-output* (output cradle))
    (close (output cradle))))

;; Read

(defmethod get-char ((cradle cradle))
  (setf (look cradle) (read-char (input cradle) NIL #\Nul)))

(defmethod get-value ((cradle cradle) test)
  (declare (type function test))
  (let ((buffer (value-buffer cradle)))
    (skip-space cradle)
    (loop for ch = (look cradle)
          while (funcall test ch)
          unless (< (length buffer) *value-length*)
          do (halt cradle "Value buffer overflow")
          do (get-char cradle)
          do (vector-push ch buffer))
    (skip-space cradle)
    (let ((value (format NIL "~a" buffer)))
      (setf (fill-pointer buffer) 0)
      value)))

(defmethod get-name ((cradle cradle))
  (unless (alpha-char-p (look cradle))
    (expected cradle "Name"))
  (get-value cradle #'alpha-char-p))

(defmethod get-number ((cradle cradle))
  (unless (digit-char-p (look cradle))
    (expected cradle "Integer"))
  (get-value cradle #'digit-char-p))

(defmethod match ((cradle cradle) ch)
  (declare (type base-char ch))
  (if (char= (look cradle) ch)
      (get-char cradle)
      (expected cradle ch))
  (skip-space cradle))

(defmethod skip-space ((cradle cradle))
  (loop for ch = (look cradle)
        while (find ch '(#\  #\Tab) :test #'char=)
        do (get-char cradle)))

;; Write

(defmethod emit ((cradle cradle) string)
  (declare (type string string))
  (let ((buffer (line-buffer cradle)))
    (with-output-to-string (stream buffer)
      (loop for buffer = (line-buffer cradle)
            for length = (length buffer)
            while (or (< length *indentation*)
                      (/= 0 (mod length *indentation*)))
            do (format stream " "))
      (when (< *line-length* (+ (length string) (length (line-buffer cradle))))
        (halt cradle "Line buffer overflow"))
      (format stream "~a" string))))

(defmethod emit-label ((cradle cradle) label)
  (declare (type string label))
  (let ((buffer (line-buffer cradle)))
    (unless (= 0 (length buffer))
      (error "Cannot label into existing content"))
    (with-output-to-string (stream buffer)
      (format stream "~a:" label))))

(defmethod emit-line ((cradle cradle) &optional string)
  (when string (emit cradle string))
  (let ((buffer (line-buffer cradle)))
    (format (output cradle) "~a~%" buffer)
    (setf (fill-pointer buffer) 0)))

(defmethod emit-op ((cradle cradle) op &rest args)
  (let ((args (mapcar #'(lambda (arg)
                          (string-downcase
                           (typecase arg
                             (integer (format NIL "0x~x" arg))
                             (keyword (case arg
                                        (:sptr "$sp")
                                        (:sp "($sp)")
                                        (otherwise (format NIL "$~a" arg))))
                             (otherwise (format NIL "~a" arg)))))
                      args)))
    (emit cradle op)
    (emit-line cradle (format NIL "~{~a~^,~}" args))))

;; Output

(defmethod factor ((cradle cradle))
  (cond
    ((char= (look cradle) #\()
     (match cradle #\()
     (expression cradle)
     (match cradle #\)))
    (T
     (emit-op cradle "li" :t0 (get-number cradle)))))

(defmethod term ((cradle cradle))
  (factor cradle)
  (loop for ch = (look cradle)
        while (find ch '(#\* #\/) :test #'char=)
        do (push-value cradle)
        do (case ch
             (#\* (multiply cradle))
             (#\/ (divide cradle))
             (otherwise (expected cradle "Mulop")))))

(defmethod add ((cradle cradle))
  (match cradle #\+)
  (term cradle)
  (pop-value cradle :t1)
  (emit-op cradle "add" :t0 :t0 :t1))

(defmethod subtract ((cradle cradle))
  (match cradle #\-)
  (term cradle)
  (pop-value cradle :t1)
  (emit-op cradle "sub" :t0 :t1 :t0))

(defmethod multiply ((cradle cradle))
  (match cradle #\*)
  (factor cradle)
  (pop-value cradle :t1)
  (emit-op cradle "mult" :t0 :t1)
  (emit-op cradle "mflo" :t0))

(defmethod divide ((cradle cradle))
  (match cradle #\/)
  (factor cradle)
  (pop-value cradle :t1)
  (emit-op cradle "div" :t1 :t0)
  (emit-op cradle "mflo" :t0)
  (emit-op cradle "mfhi" :t1))

(defmethod push-value ((cradle cradle) &optional (from :t0))
  (emit-op cradle "sub" :sptr :sptr #x4)
  (emit-op cradle "sw" from :sp))

(defmethod pop-value ((cradle cradle) &optional (into :t0))
  (emit-op cradle "lw" into :sp)
  (emit-op cradle "add" :sptr :sptr #x4))

(defmethod expression ((cradle cradle))
  (term cradle)
  (loop for ch = (look cradle)
        while (find ch '(#\+ #\-) :test #'char=)
        do (push-value cradle)
        do (case ch
             (#\+ (add cradle))
             (#\- (subtract cradle))
             (otherwise (expected cradle "Addop")))))

;; Report

(defmethod report-error ((cradle cradle) message)
  (format T "Error: ~a~%" message))

(defmethod halt ((cradle cradle) message)
  (report-error cradle message)
  (error "~a" message))

(defmethod expected ((cradle cradle) expectation)
  (halt cradle (format NIL "~a Expected" expectation)))