;;;
;;; nupi-nubus.lisp
;;;
;;; NuBus interface to the NuPI board.
;;;

(in-package :nevermore)

(declaim (type (simple-array (unsigned-byte 16) (*)) *nupi-config-rom*))
(defvar *nupi-config-rom* (make-array '(#x2000) :element-type '(unsigned-byte 16)
				      :initial-element 0))

(defvar *nupi-scsi0-0-disk-file*
  #p"/home/nyef/oldhome/src/lisp/lispm_stuff/aek/explorerI_diskDumps/explScsi0Dr0.dsk")

(defun nupi-dump-rqb-header ()
  (let ((old-memory-data (aref *memory-data*)))
    (dotimes (i 8)
      (start-nubus-read (+ old-memory-data (ash i 2)))
      (format t "Word ~X: ~X~%" i (aref *memory-data*)))
    (setf (aref *memory-data*) old-memory-data)))

(defun nupi-busmaster-read (address)
  (let ((old-memory-data (aref *memory-data*)))
    (start-nubus-read address)
    (let ((retval (aref *memory-data*)))
      (setf (aref *memory-data*) old-memory-data)
      retval)))

(defun nupi-busmaster-write (address data)
  (let ((old-memory-data (aref *memory-data*)))
    (setf (aref *memory-data*) data)
    (start-nubus-write address)
    (setf (aref *memory-data*) old-memory-data))
  (values))

(defun nupi-complete-request (rqb-address rqb-command-word)
  (declare (ignorable rqb-command-word))
  ;; FIXME: Should handle event-posting.
  (nupi-busmaster-write (+ rqb-address 4) #x40000000))

(defun nupi-handle-command-nupi-status (rqb-address rqb-command-word)
  (let ((buffer-address (nupi-busmaster-read (+ rqb-address 8)))
	(transfer-length (nupi-busmaster-read (+ rqb-address 12))))
    (declare (ignorable transfer-length))
    (nupi-busmaster-write buffer-address 0)
    (nupi-busmaster-write (+ buffer-address 4) 0)
    (dotimes (i 7)
      (nupi-busmaster-write (+ buffer-address 8 (ash i 2)) #x10000000))
    ;; Same hack as in exploiter: First formatter, first drive only.
    ;; Minor change: The drive is write-protected.
    (nupi-busmaster-write (+ buffer-address 8) 0)
    (nupi-busmaster-write (+ buffer-address #x44) #x41000000)
    (nupi-busmaster-write (+ buffer-address #x48) #x10000000))
  (nupi-complete-request rqb-address rqb-command-word)
#+nil  (break))

(defun nupi-handle-command-drive-status (rqb-address rqb-command-word)
  (let ((buffer-address (nupi-busmaster-read (+ rqb-address 8)))
	(transfer-length (nupi-busmaster-read (+ rqb-address 12))))
    (declare (ignorable transfer-length))
    (nupi-busmaster-write buffer-address #x41000000))
  (nupi-complete-request rqb-address rqb-command-word)
#+nil  (break))

(defun nupi-handle-command-drive-read (rqb-address rqb-command-word)
  (let ((buffer-address (nupi-busmaster-read (+ rqb-address 8)))
	(transfer-length (nupi-busmaster-read (+ rqb-address 12)))
	(block-address (nupi-busmaster-read (+ rqb-address 16))))
    (with-open-file (diskfile *nupi-scsi0-0-disk-file*
			      :direction :input :element-type '(unsigned-byte 8))
      (file-position diskfile (* #x400 block-address))
      (dotimes (i (ash transfer-length -2))
	(let* ((b0 (read-byte diskfile))
	       (b1 (read-byte diskfile))
	       (b2 (read-byte diskfile))
	       (b3 (read-byte diskfile))
	       (disk-word
		(dpb b3 (byte 8 24)
		     (dpb b2 (byte 8 16)
			  (dpb b1 (byte 8 8) b0)))))
	  (nupi-busmaster-write (+ buffer-address (* i 4)) disk-word)))))
  (nupi-complete-request rqb-address rqb-command-word)
#+nil  (break))

(defun nupi-command-write ()
  (format t "NuPI: Command write, RQB: ~X~%" (aref *memory-data*))
  (nupi-dump-rqb-header)
  (let* ((rqb-address (aref *memory-data*))
	 (rqb-command-word (nupi-busmaster-read rqb-address)))
    (cond ((= #x82 (ldb (byte 8 24) rqb-command-word))
	   (nupi-handle-command-nupi-status rqb-address rqb-command-word))
	  ((= #x02 (ldb (byte 8 24) rqb-command-word))
	   (nupi-handle-command-drive-status rqb-address rqb-command-word))
	  ((= #x10 (ldb (byte 8 24) rqb-command-word))
	   (nupi-complete-request rqb-address rqb-command-word)
#+nil	   (break))
	  ((= #x81 (ldb (byte 8 24) rqb-command-word))
	   (nupi-complete-request rqb-address rqb-command-word)
#+nil	   (break))
	  ((= #x12 (ldb (byte 8 24) rqb-command-word))
	   (nupi-handle-command-drive-read rqb-address rqb-command-word))
	  (t (break)))))

(defun nupi-nubus-read (slot address width)
  (declare (type (unsigned-byte 8) slot)
	   (type (unsigned-byte 24) address)
	   (ignorable slot width))
  (cond ((= (logand address #xffc000) #xffc000)
	 (setf *inhibit-nubus-trace* t)
	 (setf (aref *memory-data*)
	       (dpb (ldb (byte 8 (ash (logand 1 address) 3))
			 (aref *nupi-config-rom*
			       (logxor 1 (logand #x1fff (ash address -1)))))
		    (byte 8 (* 8 (logand 3 address))) 0)))

	;; "Flag register"? (upper half?)
	((= address #xd40002)
	 (setf (aref *memory-data*) 0))

	;; Configuration register
	((= address #xe0000b)
	 )

	(t (setf *nubus-error* t)))
  (values))

(defun nupi-nubus-write (slot address width)
  (declare (type (unsigned-byte 8) slot)
	   (type (unsigned-byte 24) address)
	   (ignorable slot width))
  (cond ((= address #xe00004)
	 (nupi-command-write))
	(t (setf *nubus-error* t)))
  (values))

;;; EOF
