(proclaim '(optimize (speed 0) (debug 3) (safety 3)))

;;; BASIC compiler for PIC

(defparameter *state* nil)
(defparameter *def-table* nil)
(defparameter *varb-table* nil)
(defparameter *var-index* nil)
(defparameter *tokens* nil)

(defun parse-decimal (string)
  (let ((result 0))
    (loop for c across string do
          (setf result (* 10 result))
          (let ((c (char-code (char-downcase c))))
            (if (and (<= c (char-code #\9))
                     (>= c (char-code #\0)))
                (incf result (- c (char-code #\0)))
              (return-from parse-decimal nil))))
    result))
              
(defun parse-hex (string)
  (let ((result 0))
    (loop for c across string do
          (setf result (* 16 result))
          (let ((c (char-code (char-downcase c))))
            (if (and (<= c (char-code #\9))
                     (>= c (char-code #\0)))
                (incf result (- c (char-code #\0)))
              (if (and (<= c (char-code #\a))
                       (>= c (char-code #\f)))
                  (incf result (+ 10 (- c (char-code #\a))))
                (return-from parse-hex nil)))))
    result))
              
(defun basic-parse-number (string)
  (if (char= (elt string 0) #\$)
      (parse-hex (subseq string 1))
    (parse-decimal string)))

(defun get-variable (name)
  (gethash name *varb-table*))

(defun rvalue (value)
  ; nil is invalid
  (unless value
    (error "wrong rvalue"))
  ; if it is a number, return it
  (when (numberp value)
    (return-from rvalue value))
  ; try to parse as a number
  (let ((number (basic-parse-number value)))
    (when number
      (return-from rvalue number)))
  ; try to get it from def table, recursive
  (let ((value (gethash value *def-table*)))
    (when value
      (return-from rvalue (rvalue value))))
  ; not found, maybe assembler defined, return string
  value)

(defun make-label (prefix level)
  (format nil "~a~a" prefix level))

(defun make-for-start-label (level)
  (make-label "_for_start" level))

(defun make-for-body-label (level)
  (make-label "_for_body" level))

(defun make-for-end-label (level)
  (make-label "_for_end" level))

(defun make-do-start-label (level)
  (make-label "_do_start" level))

(defun make-do-end-label (level)
  (make-label "_do_end" level))

(defun decimal-number (value)
  (if (numberp value)
      (format nil "D'~a'" value)
    value))

(defun next-token ()
  (pop *tokens*))

(defun basic-labelp (string)
  (char= (elt string (1- (length string))) #\:))

(defun compile-basic-program ()
  (setf *def-table* (make-hash-table :test 'equal))
  (setf *varb-table* (make-hash-table :test 'equal))
  (setf *var-index* 10)
  (loop with for-var-list = '()
        with for-index-list = '()
        with do-index-list = '()
        with for-index = 0
        with do-index = 0
        do
        (let ((token (next-token)))
          (unless token
            (loop-finish))
          (cond ((equal token :newline))
                ((basic-labelp token)
                 (format t "~a~%" (subseq token 0 (1- (length token)))))
                ((string= token "cpu")
                 (let ((type (next-token)))
                   (format t "    LIST P=~a~%" type)
                   (format t "#include \"P~a.INC\"~%" type)
                   (format t "gp0 equ 0~%")
                   (format t "gp1 equ 1~%")
                   (format t "gp2 equ 2~%")
                   (format t "gp3 equ 3~%")
                   (format t "gp4 equ 4~%")
                   (format t "gp5 equ 5~%")
                   (format t "    __CONFIG _MCLRE_OFF & _CP_OFF & _WDT_OFF & _IntRC_OSC~%")
                   (format t "    movwf OSCCAL~%")
                   (format t "    clrf STATUS~%")
                   (format t "_TRIS_CACHE EQU 8~%")
                   (format t "_GPIO_CACHE EQU 9~%")
                   (format t "    movlw D'255'~%")
                   (format t "    movwf _TRIS_CACHE~%")
                   (format t "    movlw D'0'~%")
                   (format t "    movwf _GPIO_CACHE~%")))
                ((string= token "def")
                 (let* ((name (next-token))
                        (equal-token (next-token))
                        (value (next-token)))
                   (declare (ignore equal-token))
                   (setf (gethash name *def-table*) value)))
                ((string= token "varb")
                 (let ((name (next-token)))
                   (setf (gethash name *varb-table*) *var-index*)
                   (incf *var-index*)))
                ((string= token "low")
                 (let ((value (rvalue (next-token))))
                   (format t "    bcf _GPIO_CACHE, ~a~%" (decimal-number value))
                   (format t "    movf _GPIO_CACHE, W~%")
                   (format t "    movwf GPIO~%")))
                ((string= token "high")
                 (let ((value (rvalue (next-token))))
                   (format t "    bsf _GPIO_CACHE, ~a~%" (decimal-number value))
                   (format t "    movf _GPIO_CACHE, W~%")
                   (format t "    movwf GPIO~%")))
                ((string= token "output")
                 (let ((value (rvalue (next-token))))
                   (format t "    bcf _TRIS_CACHE, ~a~%" (decimal-number value))
                   (format t "    movf _TRIS_CACHE, W~%")
                   (format t "    tris GPIO~%")))
                ((string= token "input")
                 (let ((value (rvalue (next-token))))
                   (format t "    bsf _TRIS_CACHE, ~a~%" (decimal-number value))
                   (format t "    movf	_TRIS_CACHE, W~%")
                   (format t "    tris GPIO~%")))
                ((string= token "clrwdt")
                 (format t "    clrwdt~%"))
                ((string= token "option")
                 (let* ((equal-token (next-token))
                        (value (rvalue (next-token))))
                   (declare (ignore equal-token))
                   (format t "    movlw ~a~%" (decimal-number value))
                   (format t "    option~%")))
                ((string= token "call")
                 (let ((label (next-token)))
                   (format t "    call ~a~%" label)))
                ((string= token "goto")
                 (let ((label (next-token)))
                   (format t "    goto ~a~%" label)))
                ((string= token "return")
                 (let ((value (rvalue (next-token))))
                   (format t "    retlw ~a~%" (decimal-number value))))
                ((string= token "for")
                 (let* ((var (get-variable (next-token)))
                        (equal-token (next-token))
                        (from (rvalue (next-token)))
                        (to-token (next-token))
                        (to (rvalue (next-token)))
                        (start-label (make-for-start-label for-index))
                        (end-label (make-for-end-label for-index))
                        (body-label (make-for-body-label for-index)))
                   (declare (ignore equal-token to-token))
                   (format t "    movlw ~a~%" (decimal-number from))
                   (format t "    movwf ~a~%" (decimal-number var))
                   (format t "~a~%" start-label)
                   (format t "    movlw ~a~%" (decimal-number to))
                   (format t "    subwf ~a, W~%" (decimal-number var))
                   (format t "    btfss STATUS, C~%")
                   (format t "    goto ~a~%" body-label)
                   (format t "    btfss STATUS, Z~%")
                   (format t "    goto ~a~%" end-label)
                   (format t "~a~%" body-label)
                   (push var for-var-list)
                   (push for-index for-index-list)
                   (incf for-index)))
                ((string= token "next")
                 (let* ((var (pop for-var-list))
                        (index (pop for-index-list))
                        (start-label (make-for-start-label index))
                        (end-label (make-for-end-label index)))
                   (format t "    incf ~a, F~%" (decimal-number var))
                   (format t "    goto ~a~%" start-label)
                   (format t "~a~%" end-label)))
                ((string= token "do")
                 (let* ((while-token (next-token))
                        (var (get-variable (next-token)))
                        (equal-token (next-token))
                        (value (rvalue (next-token)))
                        (start-label (make-do-start-label do-index))
                        (end-label (make-do-end-label do-index)))
                   (declare (ignore while-token equal-token))
                   (format t "~a~%" start-label)
                   (format t "    movf ~a, W~%" (decimal-number value))
                   (format t "    subwf ~a, W~%" (decimal-number var))
                   (format t "    btfss STATUS, Z~%")
                   (format t "    goto ~a~%" end-label)
                   (push do-index do-index-list)
                   (incf do-index)))
                ((string= token "loop")
                 (let* ((index (pop do-index-list))
                        (start-label (make-do-start-label index))
                        (end-label (make-do-end-label index)))
                   (format t "    goto ~a~%" start-label)
                   (format t "~a~%" end-label)))
                (t (let* ((var (get-variable token))
                          (equal-token (next-token))
                          (value (rvalue (next-token))))
                     (declare (ignore equal-token))
                     (format t "    movf ~a, W~%" (decimal-number value))
                     (format t "    movwf ~a~%" (decimal-number var)))))))
  (format t "    end~%"))

(defun is-whitespace (char)
  (member char '(#\Space #\Tab)))

(defun test ()
  (let ((program '()))
    (with-open-file (file "c:/tmp/test.bas" :direction :input)
      (loop for line = (read-line file nil) while line do
            (let ((word nil))
              (loop for c across line do
                    (if (is-whitespace c)
                        (when word
                          (if (string= word "'")
                              (progn
                                (setf word nil)
                                (loop-finish))
                            (progn
                              (push word program)
                              (setf word nil))))
                      (if word
                          (setf word (format nil "~a~a" word c))
                        (setf word (format nil "~a" c)))))
              (when word
                (push word program)))
            (push :newline program)))
    (setf *tokens* (nreverse program))
    (compile-basic-program)))