;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8; Readtable:ZL -*-

(defvar %sys-com-band-crc #o35)

(defun read-band-crc (part &optional (unit 0))
  (with-decoded-disk-unit (unit unit "read")
    (with-disk-rqb (rqb)
      (let ((part-base (find-disk-partition-for-read part nil unit)))
	(disk-read rqb unit (+ part-base 1))
	(let ((lo (aref (rqb-buffer rqb) (* %sys-com-band-crc 2)))
	      (hi (aref (rqb-buffer rqb) (1+ (* %sys-com-band-crc 2)))))
	  (let ((crc (dpb hi (byte 16. 16.) lo)))
	    (if (not (zerop (ldb %%q-cdr-code crc)))
		(ferror nil "cdr of crc word is not 0"))
	    (if (not (= (ldb %%q-data-type crc) dtp-fix))
		(ferror nil "data type of crc word is not DTP-FIX"))
	    (%make-pointer-unsigned crc)))))))

(defun write-band-crc (val part &optional (unit 0))
  (if (not (zerop (ldb %%q-cdr-code val)))
      (ferror nil "cdr-code must be 0"))
  (if (not (= (ldb %%q-data-type val) dtp-fix))
      (ferror nil "must be DTP-FIX"))
  (with-decoded-disk-unit (unit unit "write")
    (with-disk-rqb (rqb)
      (let ((first-block (find-disk-partition-for-write part nil unit)))
	(disk-read rqb unit (+ first-block 1))
	(aset (ldb (byte 16. 0) val) (rqb-buffer rqb) (* %sys-com-band-crc 2))
	(aset (ldb (byte 16. 16.) val) (rqb-buffer rqb) (1+ (* %sys-com-band-crc 2)))
	(disk-write rqb unit (+ first-block 1)))))
  val)

;compute-region-crc
;	((vma-start-read) m-1)
;	(illop-if-page-fault)
;	((m-tem) ldb (byte 16. 0) md)
;	((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;	((m-tem) ldb (byte 1 16.) a-band-crc-accumulator)
;	((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;	((m-tem) ldb (byte 16. 16.) md)
;	((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;	((m-tem) ldb (byte 1 16.) a-band-crc-accumulator)
;	((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;	((m-1) add m-1 (a-constant 1))
;	((m-2) sub m-2 (a-constant 1))
;	(jump-not-equal m-2 a-zero compute-band-crc)
;	(popj)

(defvar band-crc-accumulator)

(defun compute-region-crc (array nwords)
  (do ((adr 0 (+ adr 2))
       (end (* nwords 2))
       x)
      ((= adr end))
    (setq x (aref array adr))
    (incf band-crc-accumulator x)
    (setq x (ldb (byte 1 16.) band-crc-accumulator))
    (incf band-crc-accumulator x)
    (setq x (aref array (1+ adr)))
    (incf band-crc-accumulator x)
    (setq x (ldb (byte 1 16.) band-crc-accumulator))
    (incf band-crc-accumulator x)
    (setq band-crc-accumulator (ldb (byte 16. 0) band-crc-accumulator))
    (cerror :no-action nil nil "foo")))

(defun compute-region-crc (array nwords)
  (do ((adr 0 (+ adr 2))
       (end (* nwords 2))
       (x band-crc-accumulator))
      ((= adr end)
       (setq band-crc-accumulator x))
    (setq x (+ (aref array adr) x))
    (setq x (+ x (ldb (byte 1 16.) x)))
    (setq x (+ x (aref array (1+ adr))))
    (setq x (ldb (byte 16. 0) (+ x (ldb (byte 1 16.) x))))
    (cerror :no-action nil nil "foo")
    ))
    

(defun compute-band-crc (part &optional (unit 0) &aux blocks-to-go (rqb-blocks 100.))
  (setq blocks-to-go (measured-size-of-partition part unit))
  (with-decoded-disk-unit (unit unit "read")
    (with-disk-rqb (rqb rqb-blocks)
      (multiple-value-bind (part-base n-blocks)
	  (find-disk-partition-for-read part nil unit)
	(if (< n-blocks blocks-to-go)
	    (ferror nil "partition is ~d. long but band says it's ~d. long"
		    n-blocks blocks-to-go))
	(disk-read rqb unit part-base)
	(aset 0 (rqb-buffer rqb) (* (+ 400 %sys-com-band-crc) 2))
	(aset (ash (dpb dtp-fix %%q-data-type 0) -16.) (rqb-buffer rqb) (1+ (* (+ 400 %sys-com-band-crc) 2)))
	(setq band-crc-accumulator 0)
	(compute-region-crc (rqb-buffer rqb) (* page-size 3))
 (cerror :no-action nil nil "foo")
	(decf blocks-to-go 3)
	(if (<= blocks-to-go 0)
	    (ferror nil "invalid band size"))
	(do ((block-offset 3))
	    ((zerop blocks-to-go))
	  (format t "~d " blocks-to-go)
	  (disk-read rqb unit block-offset)
	  (let ((blocks-this-time (min blocks-to-go rqb-blocks)))
	    (compute-region-crc (rqb-buffer rqb) (* blocks-this-time 400))
	    (incf block-offset blocks-this-time)
	    (decf blocks-to-go blocks-this-time))))))
  (write-band-crc (dpb dtp-fix %%q-data-type (%make-pointer-unsigned band-crc-accumulator))
		  part unit)
  )