;; serial bytestream receiver. copies into sram
;; new VGA

(setf *test-a7*
      
      '(let ()
       
         (defun not (x)
           (if x nil -1))

         (defun next-i (i m)
           (addr-and (%+ i 4) m))

;;;;          (defun mod-m (i m)
;;;;            (if (%>= i m)
;;;;                (%- i m)
;;;;              i))


         (defun irq (x)
           (let ((ch (get-word (p-constr 57344 0) 16)) ; read serial char
                 (getpt (get-word 100 0))
                 (insrtpt (get-word 100 4)))

;             (%print ch)
;             (%print insrtpt)

             (set-word 110 insrtpt ch)

;             (%print -1)
;             (%print (get-word 110 insrtpt))

             (let ((insrtpt1 (next-i insrtpt 15)))
               (if (not (%= insrtpt1 getpt))
                   (set-word 100 4 insrtpt1)))

;             (%print (get-word 100 4))

             (let ((s (get-status)))
               (set-status (addr-ior s 128))
               x)))

         (defun getch ()
           (let ((getpt (get-word 100 0))
                 (insrtpt (get-word 100 4)))
             (if (%= getpt insrtpt)
                 -1
               (let ((ch (p-shiftl (get-word 110 getpt) 2)))
                 (set-word 100 0 (next-i getpt 15))
                 (addr-and ch 255)))))


         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga (p-shiftl pos 2) (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


;;;;          (defun print-hex (pos val)
;;;;            (let ((v val))
;;;;              (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
;;;;              (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
;;;;              (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
;;;;              (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

;; ser-out writes a byte to serial out

         (defun ser-out (ch)
           (set-byte base_ctrl 20 ch)
           (do ((x -1 (getch))) ((not (%= x -1)))))

         (set-word (p-constr 0 16) 0 (%symbol-function 'irq))


         (setq base_vga (p-constr 61440 0))
         (setq base_sram (p-constr 53248 0))
         (setq base_ctrl (p-constr 57344 0))

;;         (%print (tag-and (p-shiftr base_sram 14) 0))
;;         (%print (tag-and (p-shiftr (p-shiftl base_sram 16) 14) 0))

         (setq base_low (p-constr 0 0))

         (set-word 100 0 0) ; getpt
         (set-word 100 4 0) ; insrtpt


         (setq *st* 1)

          (do ()
              ((%= *st* 100))
            (let ((ch (getch)))
              (print-hex-byte 5336 *st*) (print-hex-byte 5348 (addr-and *k* 255))
              (print-hex-byte 5320 (addr-and (p-shiftr addr 16)  255))
              (if (not (%= ch -1))
                  
                  (cond ((and (%= *st* 11) (%> *k* 0))
                         (setf addr (%+ (%* addr 256) ch))
                         (setf *k* (%- *k* 1)))

                        ((and (%= *st* 21) (%= *k* 0))
                         (if (%= ch 32)
                             (progn
                               (ser-out 32)
                               (setf *st* 3))
                           (if (%= ch 33)
                               (progn
                                 (ser-out 33)
                                 (setf *st* 1))
                             (if (%= ch 34)
                                 (progn
                                   (setf *st* 100)
                                   (ser-out 34)
                                   (setf *x* nil))
                               (progn
                                 (setf *st* 1)
                                 (ser-out 33))))))
                                
                        ((and (%= *st* 31) (%> *k* 0))
                         (setf len (%+ (%* len 256) ch))
                         (setf *k* (%- *k* 1))
                         (setf *st* 31))
                       
                        ((and (%= *st* 41) (%= *k* 0))
                         (if (%= ch 32)
                             (progn
                               (ser-out 32)
                               (setf *y* addr)
                               (setf *k* len)
                               (setf *q* 0)
                               (setf *st* 51))
                           (progn
                             (ser-out 33)
                             (setf *st* 1))))
                       
                        ((and (%= *st* 51) (%> *k* 0))
                         (set-byte base_sram *y* ch)
                         (setf *q* (%+ *q* (get-byte base_sram *y*)))
                         (setf *y* (%+ *y* 1))
                         (setf *k* (%- *k* 1))))

                (cond ((%= *st* 1)
                       (setf addr 0) (setf *st* 11) (setf *k* 4))
                      ((and (%= *st* 11) (%= *k* 0))
                       (setf *st* 21)
                       (setf *y* addr)
                       (setf *k* 4))
                      ((and (%= *st* 21) (%> *k* 0))
                       (ser-out (addr-and *y* 255))
                       (setf *y* (p-shiftr *y* 8))
                       (setf *k* (%- *k* 1)))
                      ((%= *st* 3)
                       (setf len 0) (setf *st* 31) (setf *k* 2))
                      ((and (%= *st* 31) (%= *k* 0))
                       (setf *st* 41)
                       (setf *y* len)
                       (setf *k* 2))
                      ((and (%= *st* 41) (%> *k* 0))
                       (ser-out (addr-and *y* 255))
                       (setf *y* (p-shiftr *y* 8))
                       (setf *k* (%- *k* 1)))
                      ((and (%= *st* 51) (%= *k* 0))
                       (ser-out *q*)
                       (setf *st* 1))))))

          (setf *k* 0)
          (do-until ((%>= *k* 16))
                    (print-hex-byte (%+ 5985 (%* *k* 4)) (get-byte base_sram *k*))
                    (setf *k* (%+ *k* 1)))))