;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for CDI version 1.12
;;; Reason:
;;;  NuPI tape support.
;;; Written 7-Jul-86 10:20:06 by Gibson at site CDI Dallas
;;; while running on EXPLORER-1 from band 1
;;; with System 110.232, Lambda-Diag 7.17, Experimental Local-File 68.7, FILE-Server 18.4, Unix-Interface 9.1, ZMail 65.14, Object Lisp 3.4, Tape 6.39, Site Data Editor 3.3, Tiger 24.0, KERMIT 31.3, Window-Maker 1.1, Gateway 4.8, TCP-Kernel 39.7, TCP-User 62.7, TCP-Server 45.5, MEDIUM-RESOLUTION-COLOR 3.4, MICRO-COMPILATION-TOOLS 3.2, System Revision Level 3.26, Experimental CDI 1.11, microcode 1525, CDI LambdaE base.



; From file S2: >Lambda-3>TAPE>NUPI-SUPPORT.LISP.13 at 7-Jul-86 10:20:07
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; nupi-support lisp "

(defmacro dma-buffer-aref-32 (array index)
  (Once-Only (index)
    `(dpb (aref (dma-buffer-16b ,array) (1+ (* 2 ,index)))
	  (byte 16 16)
	  (aref (dma-buffer-16b ,array) (* 2 ,index))))
  )

))

; From file S2: >Lambda-3>TAPE>NUPI-SUPPORT.LISP.13 at 7-Jul-86 10:20:33
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; nupi-support lisp "

(defmacro dma-buffer-set-aref-32 (array index value)
  (Once-Only (index)
    `(progn
       (aset (ldb (byte 16 0) ,value) (dma-buffer-16b ,array) (* 2 ,index))
       (aset (ldb (byte 16 16) ,value) (dma-buffer-16b ,array) (1+ (* 2 ,index)))
       ,value))
  )

(defsetf dma-buffer-aref-32 dma-buffer-set-aref-32)

;;; Is this good enough?
(Defun DMA-Buffer-P (x)
  (arrayp x))

(Defun %Wired-Status? (page-status)
  (eq (ldb %%pht1-swap-status-code page-status) %pht-swap-status-wired))

(Defun %Page-Wired? (pointer)
  (%Wired-Status? (%page-status pointer)))

;;;
;;; nupi command blocks
;;;

(defun get-nupi-command-block (ignore)
  (let ((command-block (get-dma-buffer 1)))
    (setf (dma-buffer-named-structure-symbol command-block) 'nupi-command-block)
    command-block))

(defun free-nupi-command-block (command-block)
  (free-dma-buffer command-block))

(defconst %nupi-command-word 0)
(defconst %nupi-status-word 1)
(defconst %nupi-scatter-list 2)
(defconst %nupi-transfer-count 3)
(defconst %nupi-logical-block 4)
(defconst %nupi-interrupt-address 5)
(defconst %nupi-reserved-a 6)
(defconst %nupi-reserved-b 7)

(defmacro nupi-command-word (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-command-word))

(defmacro nupi-status-word (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-status-word))

(defmacro nupi-scatter-list (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-scatter-list))

(defmacro nupi-transfer-count (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-transfer-count))

(defmacro nupi-logical-block (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-logical-block))

(defmacro nupi-interrupt-address (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-interrupt-address))

(defmacro nupi-reserved-a (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-reserved-a))

(defmacro nupi-reserved-b (command-block)
  `(dma-buffer-aref-32 ,command-block %nupi-reserved-b))

(defselect ((nupi-command-block named-structure-invoke))
  (:print-self (array stream ignore ignore)
    (printing-random-object (array stream :typep)
      (When (%page-wired? array)
	(format stream "Wired #x~x; "
		(vadr-to-nubus-phys (dma-buffer-data-vadr array))))
      (format stream "Command: ~a" (or (cadr (assq (ldb (byte 8 24) (nupi-command-word array))
						   nupi-commands))
				       "Unknown"))
      (format stream "; Unit #x~x" (ldb (byte 8 0) (nupi-command-word array)))
      (Let ((status (nupi-status-word array))
	    list)
	(When (ldb-test (byte 1 31) status)
	  (push "Busy" list))
	(When (ldb-test (byte 1 30) status)
	  (push "Complete" list))
	(When (ldb-test (byte 1 29) status)
	  (push "Error" list))
	(when list
	  (format stream "; Status: ")
	  (format:print-list stream "~a" list)))
      
      (Format Stream "; Count ~d." (nupi-transfer-count array))
      (format stream "; Block ~d." (nupi-logical-block array))))
  (:describe (array)
    (format t "~&~S:" array)
    (let ((command-word (nupi-command-word array))
	  (status (nupi-status-word array))
	  (scatter-list (nupi-scatter-list array))
	  (transfer-count (nupi-transfer-count array))
	  (block (nupi-logical-block array))
	  (interrupt-address (nupi-interrupt-address array))
	  (reserved-a (nupi-reserved-a array))
	  (reserved-b (nupi-reserved-b array)))

      (format t "~&Unit #x~x" (ldb (byte 8 0) command-word))
      (format t "~&Spare ~s" (ldb (byte 8 8) command-word))
      (format t "~&Options ~s" (ldb (byte 8 16) command-word))
      (if (ldb-test (byte 1 20) command-word) (format t " Swap-partial-completion-interrupt"))
      (if (ldb-test (byte 1 21) command-word) (format t " device-address-is-physical"))
      (if (ldb-test (byte 1 22) command-word) (format t " SCATTER"))
      (if (ldb-test (byte 1 23) command-word) (format t " Interrupt-enable"))
      (format t "~&Command #x~16r ~a" (ldb (byte 8 24) command-word)
	      (cadr (assq (ldb (byte 8 24) command-word) nupi-commands)))

      (format t "~&Status ~s" status)
      (format t "~&  Busy ~s" (ldb (byte 1 31) status))
      (format t "~&  Complete ~s" (ldb (byte 1 30) status))
      (format t "~&  Error ~s" (ldb (byte 1 29) status))
      (format t "~&  Retries required ~s" (ldb (byte 1 28) status))
      (format t "~&  Aux status available ~s" (ldb (byte 1 27) status))
      (format t "~&  Paging partial completion ~s" (ldb (byte 1 26) status))
      (format t "~&  spare ~s" (ldb (byte 2 24) status))
      (let ((error (ldb (byte 8 16) status)))
	(format t "~&  controller error ~s" error)
	(when (not (zerop error))
	  (format t "  Class: \"~a\"" (nth (ldb (byte 3 21) status) nupi-error-classes))
	  (format t "  ~a" (cadr (assq error nupi-controller-errors)))
	  ))
      
      (let ((error (ldb (byte 8 8) status)))
	(format t "~&  device error ~s" error)
	(when (not (zerop error))
	  (format t "  Class \"~a\"" (nth (ldb (byte 3 13) status) nupi-error-classes))
	  (format t "  ~a " (cadr (assq error nupi-device-errors)))
	  ))
      (format t "~&  spare ~s" (ldb (byte 3 5) status))
      (format t "~&  ECC applied ~s" (ldb (byte 1 4) status))
      (format t "~&  n-retries ~s" (ldb (byte 3 0) status))

      (format t "~&scatter-list #x~16r" scatter-list)

      (format t "~&Transfer count ~d." transfer-count)
      (format t "~&Device block address ~s" block)
      (format t "~&Interrupt address #x~16r" interrupt-address)
      (format t "~&Reserved ~s ~s" reserved-a reserved-b)

      (when (ldb-test (byte 1 22) command-word)	;scatter bit
	(format t "~&Scatter list: ")
	(if (not (= (vadr-to-nubus-phys (%pointer-plus
					  (dma-buffer-data-vadr array)
					  8))
		    scatter-list))
	    (format t "~&   *** warning, scatter list doesn't really point here ***"))
	(do ((scatter-index 8 (+ scatter-index 2))
	     (pages-to-go (floor transfer-count 1024) (1- pages-to-go)))
	    ((zerop pages-to-go))
	  (format t "~&#x~8x ~d."
		  (dma-buffer-aref-32 array scatter-index)
		  (dma-buffer-aref-32 array (1+ scatter-index)))))
      ))
    
  (:which-operations (ignore)
    '(:print-self :which-operations :describe))
  )


(defun fill-in-nupi-command (command-block phys-unit command byte-count disk-address
			     dma-buffer dma-buffer-offset-in-pages
			     &aux n-pages)

  (When (or (not (%page-wired? command-block))
	    (and (dma-buffer-p dma-buffer)
		 (not (%page-wired? dma-buffer))))
    (ferror nil "COMMAND-BLOCK and DMA-BUFFER must be wired."))
  
  (Unless (zerop (ldb (byte 10 0) byte-count))
    (ferror nil "byte-count must be an even number of pages"))

  (setq n-pages (floor byte-count 1024))

  (When (and (dma-buffer-p dma-buffer)
	     (or (> (+ dma-buffer-offset-in-pages n-pages)
		    (dma-buffer-size-in-pages dma-buffer))
		 (> n-pages (floor (- page-size 8) 2))))	;number of scatter entries available
    (ferror nil "transfer request too big"))

  ;; really just need to clear first 8 words
  ;;  can't use array-initialize on 32b array, since it stores DTP-FIX tags
  (array-initialize (dma-buffer-16b command-block) 0)

  (setf (nupi-command-word command-block)
	(+ phys-unit
	   (dpb command (byte 8 24) (if (dma-buffer-p dma-buffer) #x400000 0))))	;scatter flag

  (setf (nupi-scatter-list command-block)
	(If (dma-buffer-p dma-buffer)
	    (vadr-to-nubus-phys (%pointer-plus
				  (dma-buffer-data-vadr command-block)
				  8))
	  (or dma-buffer 0)))

  (setf (nupi-transfer-count command-block) byte-count)
  (setf (nupi-logical-block command-block) disk-address)

  (when (dma-buffer-p dma-buffer)
    (do ((vadr (%pointer-plus (dma-buffer-data-vadr dma-buffer)
			      (* dma-buffer-offset-in-pages page-size))
	       (%pointer-plus vadr page-size))
	 (scatter-entry 8 (+ scatter-entry 2))
	 (pages-to-go n-pages (1- pages-to-go)))
	((zerop pages-to-go))
      (let ((padr (vadr-to-nubus-phys vadr)))
	(setf (dma-buffer-aref-32 command-block scatter-entry) padr)
	(setf (dma-buffer-aref-32 command-block (1+ scatter-entry)) 1024)))))

(defun fill-in-nupi-simple-command (command-block phys-unit command byte-count disk-address
			     dma-buffer dma-buffer-offset-in-pages
			     &aux n-pages)

  (When (or (not (%page-wired? command-block))
	    (and (dma-buffer-p dma-buffer)
		 (not (%page-wired? dma-buffer))))
    (ferror nil "COMMAND-BLOCK and DMA-BUFFER must be wired."))
  
;;;  (Unless (zerop (ldb (byte 10 0) byte-count))
;;;    (ferror nil "byte-count must be an even number of pages"))

  (setq n-pages (floor byte-count 1024))

  (When (and (dma-buffer-p dma-buffer)
	     (or (> (+ dma-buffer-offset-in-pages n-pages)
		    (dma-buffer-size-in-pages dma-buffer))
		 (> n-pages (floor (- page-size 8) 2))))	;number of scatter entries available
    (ferror nil "transfer request too big"))

  ;; really just need to clear first 8 words
  ;;  can't use array-initialize on 32b array, since it stores DTP-FIX tags
  (array-initialize (dma-buffer-16b command-block) 0)

  (setf (nupi-command-word command-block)
	(+ phys-unit
	   (dpb command (byte 8 24) 0)))

  (setf (nupi-scatter-list command-block)
	(Cond ((dma-buffer-p dma-buffer)
	       (vadr-to-nubus-phys (%pointer-plus
				     (dma-buffer-data-vadr command-block)
				     8)))
	      ((Null dma-buffer) 0)
	      (t
	       (si:dma-buffer-set-aref-32 command-block (1+ si:%nupi-reserved-b) dma-buffer)
	       (vadr-to-nubus-phys (%pointer-plus
				     (dma-buffer-data-vadr command-block)
				     8)))))

  (setf (nupi-transfer-count command-block) byte-count)
  (setf (nupi-logical-block command-block) disk-address)
  )

(defun start-nupi-command (command-block phys-unit command byte-count disk-address
			   dma-buffer dma-buffer-offset-in-pages
			   set-modified)
  (wire-wireable-array command-block 0 nil nil nil)
  ;;could arrange to do DONT-BOTHER-PAGING-IN on all pages but first
  (when (dma-buffer-p dma-buffer)
    (wire-wireable-array dma-buffer 0 nil set-modified nil))
  (fill-in-nupi-command
    command-block phys-unit command byte-count disk-address dma-buffer dma-buffer-offset-in-pages)
  (NuPI-Command-Initiate command-block)
  )

(defun start-nupi-simple-command (command-block phys-unit command byte-count disk-address
			   dma-buffer dma-buffer-offset-in-pages
			   set-modified)
  (wire-wireable-array command-block 0 nil nil nil)
  ;;could arrange to do DONT-BOTHER-PAGING-IN on all pages but first
  (when (dma-buffer-p dma-buffer)
    (wire-wireable-array dma-buffer 0 nil set-modified nil))
  (fill-in-nupi-simple-command
    command-block phys-unit command byte-count disk-address dma-buffer dma-buffer-offset-in-pages)
  (NuPI-Command-Initiate command-block)
  )

;;; This should be fixed up for the tape unit to use io-proceed.
(Defun NuPI-Command-Initiate (command-block)
  (Without-Interrupts
    (aref command-block 0)
    (%nubus-write #xF2 #xE00004
      (vadr-to-nubus-phys
	(%pointer-plus command-block (array-data-offset command-block)))))
  )


(Defun NuPI-Command-Complete-P (command-block)
  (ldb-test (byte 1 30.) (nupi-status-word command-block)))

(Defun NuPI-Command-Error-P (command-block)
  (ldb-test (byte 1 29.) (nupi-status-word command-block)))

(Defun NuPI-Check-Status (command-block)
  (Let ((device-status (ldb #o1010 (si:nupi-status-word command-block)))
	(unit (ldb (byte 8 0) (si:nupi-command-word command-block)))
	(data-transferred (si:nupi-transfer-count command-block)))
    (Selectq device-status
      ((0 #x48 #xC8)   ; no error, SCSI sense available, correctable data error: ignore.
       (When (NuPI-Command-Error-P command-block)
	 (ferror nil "nupi error"))
       nil)
      ((#x4C #x4D #x4E #x4F)
       (signal 'tape:filemark-encountered
	       :device-type 'nupi-device
	       :unit unit
	       :data-transferred data-transferred))
      ((#x4A #x4B) ; end of tape, end of recorded media
       (signal 'tape:physical-end-of-tape
	       :device-type 'nupi-device
	       :unit unit
	       :data-transferred data-transferred))))
  )


(Defun wait-for-nupi-command (command-block &optional (command "NuPI Wait"))
  (process-wait command #'NuPI-Command-Complete-P command-block)
  (NuPI-Check-Status command-block))

(Defun finish-nupi-command (command-block dma-buffer)
  (unwire-wireable-array command-block 0 nil)
  (When (dma-buffer-p dma-buffer)
    (unwire-wireable-array dma-buffer 0 nil)))

(defun nupi-logical-to-physical-unit (logical-unit)
  (dpb (ldb (byte 3 1) logical-unit)
       (byte 3 3)
       (ldb (byte 1 0) logical-unit)))

(defun simple-nupi-command (command-block command logical-unit disk-address byte-count
			    dma-buffer dma-buffer-offset-in-pages
			    set-modified &optional (command-name "NuPI Wait"))
  (start-nupi-simple-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      command
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      set-modified)
  (wait-for-nupi-command command-block command-name)
  (finish-nupi-command command-block dma-buffer))

(defun nupi-read-from-disk (command-block logical-unit disk-address byte-count dma-buffer dma-buffer-offset-in-pages)
  (start-nupi-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      #x12
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      t)
  (wait-for-nupi-command command-block "Disk Read")
  (finish-nupi-command command-block dma-buffer)
  )

(defun nupi-write-to-disk (command-block logical-unit disk-address byte-count dma-buffer dma-buffer-offset-in-pages)
  (start-nupi-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      #x13
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      t)
  (wait-for-nupi-command command-block "Disk Write")
  (finish-nupi-command command-block dma-buffer)
  )

(defun nupi-read-from-tape (command-block logical-unit disk-address byte-count dma-buffer dma-buffer-offset-in-pages)
  (start-nupi-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      #x12
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      t)
  (wait-for-nupi-command command-block "Tape Read")
  (finish-nupi-command command-block dma-buffer)
  )
  
(defun nupi-write-to-tape (command-block logical-unit disk-address byte-count dma-buffer dma-buffer-offset-in-pages)
  (start-nupi-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      #x13
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      nil)
  (wait-for-nupi-command command-block "Tape Write")
  (finish-nupi-command command-block dma-buffer))



(defun nupi-read-from-tape-proceed (command-block logical-unit disk-address byte-count dma-buffer dma-buffer-offset-in-pages)
  (start-nupi-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      #x12
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      t)
  )

(defun nupi-write-to-tape-proceed (command-block logical-unit disk-address byte-count dma-buffer dma-buffer-offset-in-pages)
  (start-nupi-command command-block
		      (nupi-logical-to-physical-unit logical-unit)
		      #x13
		      byte-count
		      disk-address
		      dma-buffer
		      dma-buffer-offset-in-pages
		      nil))


(defun streamer-tape-request-complete (command-block command-name)
  (process-wait command-name #'NuPI-Command-Complete-P command-block)
  (NuPI-Check-Status command-block)
  (finish-nupi-command command-block nil)
  )
))

; From file S2: >Lambda-3>TAPE>NUPI-DEVICE.LISP.28 at 7-Jul-86 10:20:43
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; nupi-device lisp "

;;; -*- Mode:LISP; Package:TAPE; Readtable:CL; Base:10 -*-
;;;
;;; Nupi tape device for explorer.
;;;
;;; -dg 11/26/85
;;;

(defflavor nupi-device ((unit 6)
			(density :ignore)
			(command-block (si:get-nupi-command-block nil)))
	   (basic-tape-device)
  :gettable-instance-variables)


(DefMethod (nupi-device :print-self) (stream ignore slashify)
  (If slashify
      (si:printing-random-object (self stream)
	(format stream "Unit: ~d" unit))
    (format stream "NuPI"))
  )

(defmethod (nupi-device :set-options) (&rest ignore))

(defmethod (nupi-device :deinitialize) ()
  )

(defmethod (nupi-device :lock-device) (&rest ignore))
(defmethod (nupi-device :unlock-device) (&rest ignore))
(defmethod (nupi-device :device-locked-p) (&rest ignore) t)

(defmethod (nupi-device :reset) (&rest ignore)
  (send self :initialize))

(defmethod (nupi-device :status) (&rest ignore))

(defmethod (nupi-device :optimal-chunk-size) (record-size)
  record-size
  )


(defmethod (nupi-device :rewind) (&optional (wait-p t))
  (si:start-nupi-simple-command
    command-block
    (si:nupi-logical-to-physical-unit unit)
    #x20 0 0 nil nil nil)
  (When wait-p
    (si:wait-for-nupi-command command-block "Tape Rewind")
    (si:finish-nupi-command command-block nil))
  )

(defmethod (nupi-device :unload) ()
  (si:simple-nupi-command
    command-block #x21 unit 0 0 nil nil nil "Tape Unload")
  )

(defmethod (nupi-device :speed-threshold) (record-size)
  record-size
  -1)


(defmethod (nupi-device :space) (number-of-records &optional (speed :low))
  (check-type number-of-records (integer 1))
  (check-type speed (member :high :low))
  ;; Convert from LMFL (4096 byte) blocks to NuPI (1024 byte) blocks.
  (Let ((number-of-blocks (/ (* number-of-records 4096.) 1024.)))
    (condition-case ()
	(si:simple-nupi-command
	 command-block #x23 unit 0 4 number-of-blocks 0 nil "Tape Space")
      (tape:filemark-encountered )))
  )



(defmethod (nupi-device :space-reverse) (number-of-records &optional (speed :low))
  (check-type number-of-records (integer 1))
  (check-type speed (member :high :low))
  (signal 'tape:driver-error
	  :device-type 'nupi-device
	  :error-code #x23
	  :error-message "Space Reverse operation not available.")
  )


(defmethod (nupi-device :search-filemark) (number-of-filemarks &optional (speed :low))
  speed ; not used
  (si:simple-nupi-command
    command-block #x27 unit 0 4 number-of-filemarks 0 nil "Tape Search FM")
  )


(defmethod (nupi-device :search-filemark-reverse) (number-of-filemarks &optional (speed :low))
  number-of-filemarks
  speed
  (signal 'tape:driver-error
	  :device-type 'nupi-device
	  :error-code  #x27
	  :error-message "Search Reverse Filemark operation not available.")
  )


(defmethod (nupi-device :read-block) (dma-buffer record-size)
  (setq record-size 4096)
  (si:nupi-read-from-tape command-block unit 0 record-size dma-buffer 0))


(defmethod (nupi-device :write-block) (dma-buffer record-size)
  (si:nupi-write-to-tape command-block unit 0 record-size dma-buffer 0))


(defmethod (nupi-device :read-array) (array number-of-records record-size)
  (check-arg array (memq (array-type array) `(art-8b art-string art-16b art-32b))
			 "an art-8, art-string, art-16b or art-32b array")
  (let* ((nbytes (* record-size number-of-records))
	 (npages (ceiling nbytes (* si:page-size 4))))
    (Condition-Case (error)
	(using-resource (buffer si:dma-buffer npages)
	  (with-buffer-wired (buffer npages)
	    (si:nupi-read-from-tape
	      command-block unit 0 nbytes buffer 0)
	    (case (array-type array)
	      ((art-8b art-string)
	       (si:copy-array-portion
		 (si:dma-buffer-string buffer) 0 nbytes
		 array 0 nbytes))
	      (art-16b
	       (check-arg record-size (zerop (remainder nbytes 2))
			  "a half-word even record-size for an art-16b array")
	       (si:copy-array-portion
		 (si:dma-buffer-16b buffer) 0 (/ nbytes 2)
		 array 0 (/ nbytes 2)))
	      (art-32b
	       (if (eq (named-structure-p array) 'si:dma-buffer)
		   (copy-array-portion
		     (si:dma-buffer-string buffer) 0 nbytes
		     (si:dma-buffer-string array) 0 nbytes)
		 (ferror nil "Error... cannot copy art-32b array."))))))
      (tape:physical-end-of-tape
       ;; Handle this error and generate a new with the right data transfer value.
       (signal 'tape:physical-end-of-tape
	       :device-type 'nupi-device
	       :unit unit
	       :data-transferred (truncate (Send error :data-transferred) record-size)))))
  )


(defmethod (nupi-device :write-array) (array number-of-records record-size)
  (check-arg array (memq (array-type array) `(art-8b art-string art-16b art-32b))
	     "an art-8, art-string, art-16b or art-32b array")
  (let* ((nbytes (* record-size number-of-records))
	 (npages (ceiling nbytes (* si:page-size 4))))
    (Condition-Case (error)
	(using-resource (buffer si:dma-buffer npages)
	  (case (array-type array)
	    ((art-8b art-string)
	     (si:copy-array-portion
	       array 0 nbytes
	       (si:dma-buffer-string buffer) 0 nbytes))
	    (art-16b
	     (check-arg record-size (zerop (remainder nbytes 2))
			"a half-word even record-size for an art-16b array")
	     (si:copy-array-portion
	       array 0 (/ nbytes 2)
	       (si:dma-buffer-16b buffer) 0 (/ nbytes 2)))
	    (art-32b
	     (if (eq (named-structure-p array) 'si:dma-buffer)
		 (copy-array-portion
		   (si:dma-buffer-string array) 0 nbytes
		   (si:dma-buffer-string buffer) 0 nbytes)
	       (ferror nil "Error... cannot copy art-32b array."))))
	  (with-buffer-wired (buffer npages)
	    (si:nupi-write-to-tape
	      command-block unit 0 nbytes buffer 0)))
      (tape:physical-end-of-tape
       ;; Handle this error and generate a new with the right data transfer value.
       (signal 'tape:physical-end-of-tape
	       :device-type 'nupi-device
	       :unit unit
	       :data-transferred (truncate (Send error :data-transferred) record-size)))))
    )


(Defun Report-Progress (old-progress-count block-count granularity)
  (Let ((progress-count (truncate block-count granularity)))
    (When (> progress-count old-progress-count)
      (Format t " ~d" progress-count))
    progress-count)
  )


(defconst *block-transfer-size* 20.)
(defconst *streaming-priority* 20.)


(Defun streamer-tape-block-request-complete (tape-command-block blocks-transferred command-name)
  (Condition-Case (error)
      (si:streamer-tape-request-complete tape-command-block command-name)
    (tape:physical-end-of-tape
     ;; Handle this error and generate a new with the right data transfer value.
     (signal 'tape:physical-end-of-tape
	     :device-type 'nupi-device
	     :unit (ldb (byte 8 0) (si:nupi-command-word tape-command-block))
	     :data-transferred (+ blocks-transferred
				  (truncate (Send error :data-transferred) 1024.)))))
  )


(defmethod (nupi-device :write-from-disk)
	   (disk-unit starting-block number-of-blocks record-size &key silent)
  (check-arg record-size (zerop (remainder record-size (* si:page-size 4)))
	     "a page-even record-size")
  (let* ((chunk-size (min *block-transfer-size* number-of-blocks))
	 (old-priority (Send si:current-process :priority))
	 number-of-chunks
	 last-chunk-size)
    (multiple-value-bind (a b)
	(floor number-of-blocks chunk-size)
      (setq number-of-chunks (if (zerop b) a (add1 a))
	    last-chunk-size (if (zerop b) chunk-size b)))
    (Unless silent
      (Format t "~&Writing ~d blocks to tape (starting at ~d.) Counting hundreds:"
	      number-of-blocks starting-block))
    (Unwind-Protect
	(using-resource (buffer-1 si:dma-buffer chunk-size)
	  (using-resource (buffer-2 si:dma-buffer chunk-size)
	    (using-resource (disk-command-block si:dma-buffer 1)
	      (setf (si:dma-buffer-named-structure-symbol disk-command-block) 'si:nupi-command-block)
	      (using-resource (tape-command-block si:dma-buffer 1)
		(setf (si:dma-buffer-named-structure-symbol tape-command-block) 'si:nupi-command-block)
		(Let ((transfer-size (* chunk-size si:page-size 4))
		      (address starting-block))
		  (Send si:current-process :Set-Priority *streaming-priority*)
		  (si:nupi-read-from-disk
		    disk-command-block disk-unit address transfer-size buffer-1 0)
		  (si:nupi-write-to-tape-proceed
		    tape-command-block unit 0 transfer-size buffer-1 0)
		  (do ((count 1 (add1 count))
		       (progress-count 0)
		       (last-transfer-size chunk-size)
		       (buffer-1? t (not buffer-1?)))
		      ((> count number-of-chunks)
		       ;; Wait for last tape command to complete.
		       (streamer-tape-block-request-complete tape-command-block
			 (- address starting-block last-transfer-size) "Tape Write"))
		    (incf address chunk-size)
		    (When (= count number-of-chunks)
		      (Setq chunk-size last-chunk-size
			    transfer-size (* chunk-size si:page-size 4)))
		    ;; Read into buffer not used by tape request.
		    (si:nupi-read-from-disk
		      disk-command-block disk-unit address transfer-size
		      (If buffer-1? buffer-2 buffer-1) 0)
		    ;; Wait for tape request to complete.
		    (streamer-tape-block-request-complete tape-command-block
		      (- address starting-block last-transfer-size) "Tape Write")
		    ;; Start next tape request.
		    (si:nupi-write-to-tape-proceed
		      tape-command-block unit 0 transfer-size (If buffer-1? buffer-2 buffer-1) 0)
		    (setq last-transfer-size chunk-size)
		    (Unless silent
		      (Setq progress-count
			    (Report-Progress progress-count (- address starting-block) 100.)))))))))
      (Send si:current-process :Set-Priority old-priority)))
  )


(Defun Compare-Buffers (buffer-a buffer-b size)
  (let ((alphabetic-case-affects-string-comparison t))
    (Unless (%string-equal buffer-a 0 buffer-b 0 size)
      (string-compare buffer-a buffer-b)))
  )

(Defun Buffer-Compare (buffer-a buffer-b size block-number address error-list)
  (Let ((compare
	  (compare-buffers
	    (si:dma-buffer-string buffer-a) (si:dma-buffer-string buffer-b) size)))
    (If (Null compare)
	error-list
      (format *error-output* "~& Error in record number ~d; Byte: ~d"
	      block-number (abs compare))
      (cons (cons block-number address) error-list)))
  )


(defmethod (nupi-device :compare-to-disk)
	   (disk-unit starting-block number-of-blocks record-size &key silent)
  (check-unit disk-unit)
  (check-type starting-block (integer 0))
  (check-type number-of-blocks (integer 0))
  (check-type record-size (integer 1))
  (let* ((chunk-size (min *block-transfer-size* number-of-blocks))
	 (old-priority (Send si:current-process :priority))
	 number-of-chunks
	 last-chunk-size
	 error-list)
    (multiple-value-bind (a b)
	(floor number-of-blocks chunk-size)
      (setq number-of-chunks (if (zerop b) a (add1 a))
	    last-chunk-size (if (zerop b) chunk-size b)))
    (Unless silent
      (Format t "~&Comparing ~d blocks to disk. Counting hundreds:" number-of-blocks))
    (unwind-protect
     (using-resource (tape-buffer-1 si:dma-buffer chunk-size)
      (using-resource (tape-buffer-2 si:dma-buffer chunk-size)
       (using-resource (disk-buffer si:dma-buffer chunk-size)
	(using-resource (disk-command-block si:dma-buffer 1)
	  (setf (si:dma-buffer-named-structure-symbol disk-command-block) 'si:nupi-command-block)
	  (using-resource (tape-command-block si:dma-buffer 1)
	    (setf (si:dma-buffer-named-structure-symbol tape-command-block) 'si:nupi-command-block)
	    (Let ((transfer-size (* chunk-size si:page-size 4))
		  (last-transfer-size 0)
		  (address starting-block))
	      (Send si:current-process :Set-Priority *streaming-priority*)
	      (si:nupi-read-from-tape-proceed
		tape-command-block unit 0 transfer-size tape-buffer-1 0)
	      (do ((count 1 (add1 count))
		   (progress-count 0)
		   (buffer-1? t (not buffer-1?)))
		  ((>= count number-of-chunks)
		   (si:nupi-read-from-disk
		     disk-command-block disk-unit address transfer-size disk-buffer 0)
		   (streamer-tape-block-request-complete
		     tape-command-block (- address starting-block) "Tape Read")
		   (Setq error-list
			 (buffer-compare
			   disk-buffer
			   (if buffer-1? tape-buffer-1 tape-buffer-2)
			   transfer-size
			   (* count chunk-size)
			   address
			   error-list)))
		(si:nupi-read-from-disk
		  disk-command-block disk-unit address transfer-size disk-buffer 0)
		(Setq last-transfer-size transfer-size)

		;; Wait for tape request to complete.
		(streamer-tape-block-request-complete
		  tape-command-block (- address starting-block) "Tape Read")

		;; Start next tape read request (into other buffer.)
		(When (= count number-of-chunks)
		  (Setq chunk-size last-chunk-size
			transfer-size (* chunk-size si:page-size 4)))
		(si:nupi-read-from-tape-proceed
		  tape-command-block unit 0 transfer-size (If buffer-1? tape-buffer-2 tape-buffer-1) 0)

		(Setq error-list
		      (buffer-compare
			disk-buffer
			(if buffer-1? tape-buffer-1 tape-buffer-2)
			last-transfer-size
			(* count chunk-size)
			address
			error-list))
		(Unless silent
		  (Setq progress-count (Report-Progress progress-count (- address starting-block) 100.)))
		(incf address chunk-size))))))))
      (Send si:current-process :Set-Priority old-priority))
    (Unless (Null error-list)
      (nreverse error-list) t))
  )

(defmethod (nupi-device :read-to-disk)
	   (disk-unit starting-block number-of-blocks record-size &key silent)
  (check-arg record-size (zerop (remainder record-size (* si:page-size 4)))
	     "a page-even record-size")
  (let* ((chunk-size (min *block-transfer-size* number-of-blocks))
	 (old-priority (Send si:current-process :priority))
	 number-of-chunks
	 last-chunk-size)
    (multiple-value-bind (a b)
	(floor number-of-blocks chunk-size)
      (setq number-of-chunks (if (zerop b) a (add1 a))
	    last-chunk-size (if (zerop b) chunk-size b)))
    (Unless silent
      (Format t "~&Reading ~d blocks from tape. Counting hundreds:" number-of-blocks))
    (Unwind-Protect
	(using-resource (buffer-1 si:dma-buffer chunk-size)
	  (using-resource (buffer-2 si:dma-buffer chunk-size)
	    (using-resource (disk-command-block si:dma-buffer 1)
	      (setf (si:dma-buffer-named-structure-symbol disk-command-block) 'si:nupi-command-block)
	      (using-resource (tape-command-block si:dma-buffer 1)
		(setf (si:dma-buffer-named-structure-symbol tape-command-block) 'si:nupi-command-block)
		(Let ((transfer-size (* chunk-size si:page-size 4))
		      (address starting-block))
		  (Send si:current-process :Set-Priority *streaming-priority*)
		  (si:nupi-read-from-tape-proceed
		    tape-command-block unit 0 transfer-size buffer-1 0)
		  (do ((count 1 (add1 count))
		       (progress-count 0)
		       (buffer-1? t (not buffer-1?)))
		      ((> count number-of-chunks)
		       ;; Wait for last tape request to complete.
		       (streamer-tape-block-request-complete
			 tape-command-block (- address starting-block) "Tape Read")
		       (si:nupi-write-to-disk
			 disk-command-block disk-unit address transfer-size
			 (If buffer-1? buffer-1 buffer-2) 0))
		    ;; Wait for tape request to complete.
		    (streamer-tape-block-request-complete
		      tape-command-block (- address starting-block) "Tape Read")
		    (When (= count number-of-chunks)
		      (Setq chunk-size last-chunk-size
			    transfer-size (* chunk-size si:page-size 4)))
		    ;; Start read into other buffer.
		    (si:nupi-read-from-tape-proceed
		      tape-command-block unit 0 transfer-size (If buffer-1? buffer-2 buffer-1) 0)
		    ;; Write completed buffer to disk.
		    (si:nupi-write-to-disk
		      disk-command-block disk-unit address transfer-size
		      (If buffer-1? buffer-1 buffer-2) 0)
		    (incf address chunk-size)
		    (Unless silent
		      (Setq progress-count (Report-Progress progress-count (- address starting-block) 100.)))))))))
      (Send si:current-process :Set-Priority old-priority)))
  )


(defmethod (nupi-device :write-filemark) (&optional (number-of-marks 1))
  (dotimes (j number-of-marks)
    (si:simple-nupi-command
      command-block #x25 unit 0 0 nil nil nil "Tape Write FM")))


(defmethod (nupi-device :erase-tape) ()
  (si:simple-nupi-command
    command-block #x22 unit 0 0 nil nil nil "Tape Erase")
  )



(defmethod (nupi-device :initialize) (&rest ignore)
  ;; BUFFERED       -  set mode to stream (tells formatter to use buffered vs. unbuffered mode).
  ;; SPEED          -  1 = low, 0 & 2 = high, 3 = auto-adjust
  ;; DENSITY        -  0 formatter defaults (Explorer default), 4 QIC-11 (Symbolics & NuMachine)
  ;;                   6 1/2 inch 3200 bpi,  1-3 variations of 1/2 inch
  ;; BLOCK-SIZE     -  Size in bytes of blocks on tape, (24 bit field).
  ;; This command is send to the formatter (controller) rather than to the tape unit itself.
  (let ((buffered T)
	(speed 0)
	(density-code 0)
	(block-size #x200)
	(long-erase T)
	(unload-retension nil)
	(load-retension nil)
	(parms (* 2 (1+ si:%nupi-reserved-b)))
	(buffer (si:dma-buffer-16b command-block)))
    ;; This next word in the parameter block is RESERVED in SCSI spec but NUPI uses it!!
    (aset 12. buffer parms)   ; scsi data length.
    (let ((half-word (dpb (if long-erase 0 1) #o1701	        ; Info for NUPI only.  Not part of 
			  (dpb (if unload-retension 1 0) #o1601	; this SCSI command!!!
			       (dpb (if load-retension 1 0) #o1501 0)))))
      (aset half-word buffer (+ parms 1)))
    ;; From here down we're stuffing params strictly according to SCSI
    ;; halfword    -     SCSI bytes in parameter list
    ;;    3                   2,3
    ;; halfword    -     SCSI bytes in descriptor block
    ;;    4                   0,1    density-code, number-of-blocks MSB
    ;;    5                   2,3    number-of-blocks  (middle, LSB)
    ;;    6                   4,5    reserved, Block Size MSB
    ;;    7                   6,7    Block Size (middle, LSB)
    (aset #x0000 buffer (+ parms 2))
    (let ((half (dpb (if buffered 1 0) #o0401 #x0800)))	 ; 8 is constant=bytes left (block descriptor)
      (aset (dpb speed #o0002 half) buffer (+ parms 3)))
    (aset (dpb density-code #o0004 0) buffer (+ parms 4))
    (aset (dpb (ldb #o2010 block-size) #o1010 0) buffer (+ parms 6))  ; MSB
    (aset (dpb (ldb #o0010 block-size) #o1010	   ; middle & LSB
	       (dpb (ldb #o1010 block-size) #o0010 0))
	  buffer (+ parms 7))
    ;; Send formatter setup command. +++ dma-buffer parameter is just a place holder +++
    (si:simple-nupi-command
      command-block #x41 unit 0 16. command-block 0 nil "Tape Initialize"))
  )


(defun nupi-device-present? ()
  (select-processor
    (:explorer t)
    (:cadr)
    (:lambda)))

(define-tape-device nupi-device "nt" nupi-device-present?)

))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.194 at 7-Jul-86 10:20:51
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "

;;; -*- Mode:LISP; Package:TAPE; Readtable:CL; Base:10 -*-
;;
;; Copyright LISP Machine, Inc. 1986
;;   See filename "Copyright" for
;; licensing and release information.
;;;
;;; Support for the LMFL Format
;;;
;;; -dg 9/16/85
;;; -wbg 6/86
;;;

(defconstant *lmfl-default-record-size* 4096)

(defconstant *bytes-per-page* (* si:page-size 4))

(Defun Get-Next-Tape (message format device)
  (terpri) (princ message)
  (send device :rewind)
  (send device :unload)
  (prompt-for-new-tape format device)
  )

;;;
;;; LMFL format flavor definition.
;;;

(defflavor lmfl-format ((record-size)
			(file-stream)
			(tape-modified)
			(current-plist))
	   (basic-tape-format)
  (:gettable-instance-variables))


(defmethod (lmfl-format :initialize) (&rest init-options)
  (check-attribute-list init-options)
  (unless record-size
    (setq record-size *lmfl-default-record-size*))
  (when init-options
    (lexpr-send self :set-options init-options)))


(defmethod (lmfl-format :set-options) (&rest options)
  (check-attribute-list options)
  (if options
      (do* ((l options (cddr l))
	    (option (car l) (car l))
	    (value (cadr l) (cadr l)))
	   ((null l))
	(case option
	  (:record-size
	   (check-type value (integer 1024 #.(* 64 1024)))
	   (check-arg value (zerop (remainder value 1024))
		      "a multiple of 1024 bytes")
	   (setq record-size value))
	  (t (signal 'invalid-option :object self :option option :value value))))
    (tv:choose-variable-values
      `((,(locf record-size) "Record Size" :number))
      :label '(:string "Options for the LMFL tape format" :font fonts:tr12b))))


(defmethod (lmfl-format :read-tape-header) (&rest ignore))
(defmethod (lmfl-format :write-tape-header) (&rest ignore))


(defmethod (lmfl-format :tape-is-your-format-p) (device)
  (check-device device)
  (send self :rewind device t)
  (prog1
    (using-resource (header-block si:dma-buffer (/ record-size si:page-size 4))
      (send device :read-block header-block record-size)
      (string-equal "LMFL" (si:dma-buffer-string header-block) :end2 4))
    (send self :rewind device)))


(defmethod (lmfl-format :space-to-end-of-this-file) (device plist records-passed)
  (check-device device)
  (check-plist plist)
  (check-type records-passed (or null (integer 0)))
  (do* ((total-records (add1 (ceiling (if (get plist :partition)
					  (* (get plist :size) si:page-size 4)
					(* (or (get plist :length-in-bytes)
					       (get plist :length)
					       (ferror nil "length-in-bytes is NIL!"))
					   (/ (file-byte-size plist) 8)))
				      record-size)))
	(passed records-passed)
	(records-to-space-over (- total-records passed) (- total-records passed)))
       ((condition-case (condition)
	    (progn
	     (Setq current-plist nil)
	     (send device :space records-to-space-over
		   (if (> (* records-to-space-over record-size)
			  (send device :speed-threshold record-size))
		       :high
		     :low))
	     t)
	  (physical-end-of-tape
	   (Let ((data-transferred (send condition :data-transferred)))
	     (if (= data-transferred (sub1 records-to-space-over))
		 ;;if end of tape is where filemark would be ignore it for now
		 t
	       (format t "~&File continued on next tape.  Unloading this tape.")
	       (send device :rewind)
	       (send device :unload)
	       (send self :find-continuation-tape device plist)
	       (incf passed data-transferred)
	       nil))))))
  )


(defmethod (lmfl-format :read-file-header) (device &optional (host-for-parsing si:local-host))
  (check-device device)
  (check-host host-for-parsing)
  (If (Not (Null current-plist))
      current-plist
    (let ((*read-base* 10.))
      (using-resource (header-block si:dma-buffer (/ record-size si:page-size 4))
	(condition-case ()
	    (send device :read-block header-block record-size)
	  ((filemark-encountered physical-end-of-tape)
	   (signal 'logical-end-of-tape :device-object device))
	  (:no-error
	   (let* ((string (si:dma-buffer-string header-block))
		  plist)
	     (unless (string-equal string "LMFL" :end1 4)
	       (signal 'bad-file-header
		       :format-type 'lmfl
		       :header string))
	     (setq plist (read-from-string string nil :no-plist :start 4))
	     (if (atom (cdr plist))
		 (signal 'bad-file-header
			 :format-type 'lmfl
			 :header string)
	       (Setq current-plist
		     (cons (when host-for-parsing
			     (fs:make-pathname :host host-for-parsing
					       :device (getf plist :device)
					       :directory (getf plist :directory)
					       :name (getf plist :name)
					       :type (getf plist :type)
					       :version (getf plist :version)))
			   (check-plist-validity
			     (dolist (elem '(:directory :device :name :type :version) plist)
			       (remf plist elem))))))))))))
  )


(defmethod (lmfl-format :restore-partition) (plist device silent)
  (check-plist plist)
  (check-device device)
  (let ((size (get plist :size))
	(comment (or (get plist :comment) (get plist :name))))
    (multiple-value-bind (host unit start ignore ignore name)
	(When (yes-or-no-p "Restore Partition ~s? " comment)
	  (partition-searcher (format nil "for writing partition ~a" comment) size
	     :confirm-write t :default-unit tframe:*default-disk-unit*)) ;; +++
      (unwind-protect
	  (if (null host)
	      (progn 
		(format t "~&*** User Aborted restoring partition: ~A ***" comment)
		(send self :space-to-end-of-this-file device plist 0))
	    (si:update-partition-comment name "Incomplete Copy" unit)
	    (do ((first-block start)
		 (blocks size)
		 finished?)
		(finished?)
	      (Setq current-plist nil)
	      (condition-case (condition)
		  (send device :read-to-disk unit first-block blocks record-size :silent silent)
		(physical-end-of-tape
		 (Get-Next-Tape "Partition continued on another tape.  Unloading..." self device)
		 (incf first-block (send condition :data-transferred))
		 (decf blocks (send condition :data-transferred)))
		(:no-error
		 (si:update-partition-comment name (or (get plist :comment) "??? from tape") unit)
		 (condition-case (condition)
		     (send device :space 1)
		   (physical-end-of-tape))
		 (setq finished? t)))))
	(when unit (si:dispose-of-unit unit))))))


(defmethod (lmfl-format :restore-file) (device &key transform
					(overwrite :never)
					query
					(create-directory :always)
					silent)
  (check-device device)
  (check-type transform (or string pathname compiled-function closure symbol))
  (check-type overwrite (member :query :never :always))
  (check-type create-directory (member :query :never :always :error))
  (let ((chunk-size (floor (send device :optimal-chunk-size record-size)
			   *bytes-per-page*))
	(plist (send self :read-file-header device si:local-host)))
    (if (get plist :partition)
	(send self :restore-partition plist device silent)
      (let* ((byte-size (file-byte-size plist))
	     (length-in-bytes (or (get plist :length-in-bytes)
				  (get plist :length)))
	     (pathname (determine-restore-file-pathname
			 plist transform overwrite query create-directory silent)))
	(if (null pathname)
	    (send self :space-to-end-of-this-file device plist 0)
	  (with-open-file (outstream pathname
				     :direction :output
				     :byte-size byte-size
				     :characters (get plist :characters))
	    (dolist (prop '(:length-in-blocks :length-in-bytes :length
					      :byte-size :not-backed-up :characters))
	      (remprop plist prop))
	    (lexpr-send outstream :change-properties pathname (cdr plist))
	    (using-resource (buffer si:dma-buffer chunk-size)
	      (do* ((chunk-size-in-bytes (* chunk-size si:page-size (/ 32 byte-size)))
		    (record-size-in-bytes (/ record-size (/ byte-size 8)))
		    (buffer-array (case byte-size
				    (8 (si:dma-buffer-string buffer))
				    (16 (si:dma-buffer-16b buffer))))
		    (bytes-to-go length-in-bytes)
		    (bytes-this-transfer (min bytes-to-go chunk-size-in-bytes)
					 (min bytes-to-go chunk-size-in-bytes)))
		   ((zerop bytes-to-go))
		(Setq current-plist nil)
		(condition-case (condition)
		    (send device :read-array
			  buffer-array
			  (ceiling bytes-this-transfer record-size-in-bytes)
			  record-size)
		  (physical-end-of-tape
		   (let* ((data-transferred (send condition :data-transferred))
			  (bytes-left (- bytes-this-transfer (* data-transferred record-size))))
		     (send outstream :string-out buffer-array 0 (* data-transferred record-size))
		     (tv:beep)
		     (format t "~&Tape continued on another tape.  Unloading this tape.")
		     (send device :rewind)
		     (send device :unload)
		     (send self :find-continuation-tape device plist)
		     (send device :read-array
			   buffer-array
			   (ceiling bytes-left record-size)
			   record-size)
		     (send outstream :string-out buffer-array 0 bytes-left)))
		   (:no-error
		     (send outstream :string-out buffer-array 0 bytes-this-transfer)))
		(decf bytes-to-go bytes-this-transfer)))
	    (Setq current-plist nil)
	    (condition-case (condition)
		(send device :space 1)
	      (physical-end-of-tape))))))))


(defmethod (lmfl-format :write-file-header) (device truename attribute-list)
  (check-device device)
  (check-type truename pathname)
  (check-attribute-list attribute-list)
  (let* ((*print-base* 10.)
	 (plist (nconc (unless (getf attribute-list :partition)
			 (list :device (pathname-device truename)
			       :directory (pathname-directory truename)
			       :name (pathname-name truename)
			       :type (pathname-type truename)
			       :version (pathname-version truename)))
		       attribute-list))
	 (string (format nil "LMFL~S" plist)))
    (using-resource (header-block si:dma-buffer (/ record-size si:page-size 4))
      (copy-array-contents string (si:dma-buffer-string header-block))
      (Setq current-plist nil)
      (send device :write-block header-block record-size)
      (setq tape-modified t))))


(defmethod (lmfl-format :write-partition) (partition-name device unit-arg &key
					   silent end start)
  (check-type partition-name string)
  (check-type start (or null (integer 0)))
  (check-type end (or (integer 0) (member t nil)))
  (check-device device)
  (check-type unit-arg (or (integer 0) string closure))
  (si:with-decoded-disk-unit (unit unit-arg "for reading partition")
    (multiple-value-bind (beg length nil name)
	(si:find-disk-partition partition-name nil unit)
      (unless beg
	(ferror 'no-such-partition
		:host (unit-host unit)
		:disk-unit (unit-number unit)
		:partition partition-name))
      (setq start (or start beg)
	    end (cond ((null end)
		       (+ (or (si:measured-from-part-size unit name beg length) length) start))
		      ((integerp end) (+ start end))
		      (t (+ beg length))))
      (unless (and (< start end)
		   (>= start beg)
		   (<= end (+ beg length)))
	(ferror nil "Partition start or end specifications out of bounds."))
      (Setq current-plist nil)
      (using-resource (buffer si:dma-buffer (/ record-size si:page-size 4))
	(let ((*print-base* 10.)
	      (plist (list :partition t :name name :size (- end start)
			   :comment (si:partition-comment name unit)
			   :byte-size 16.
			   :host (unit-host unit) :host-unit (unit-number unit)
			   :creation-date (time:get-universal-time))))
	  (copy-array-contents
	    (format nil "LMFL~s" plist)
	    (si:dma-buffer-string buffer))
	  (setq tape-modified t)
	  (with-device-locked device
	    (send device :write-block buffer record-size)))
	(do ((addr start)
	     (blocks-to-write (- end start)))
	    ((zerop blocks-to-write))
	  (with-device-locked device
	    (condition-case (condition)
		(Progn
		 (setq tape-modified t)
		 (send device :write-from-disk
		       unit addr blocks-to-write record-size :silent silent))
	      (physical-end-of-tape
	       (setq tape-modified nil)
	       (Get-Next-Tape "End of tape during partition. Unloading tape..." self device)
	       (Let ((data-transferred (send condition :data-transferred)))
		 (Incf addr data-transferred)
		 (Decf blocks-to-write data-transferred)))
	      (:no-error
	       (setq blocks-to-write 0)
	       (condition-case ()
		   (send device :write-filemark)
		 (physical-end-of-tape))))))))))


(defmethod (lmfl-format :write-file) (device file &key (end-of-tape-action :continue) silent)
  (check-device device)
  (check-type file (or string pathname list))
  (check-type end-of-tape-action (member :continue :error :return))
  (let ((pathname (if (consp file) (fs:parse-pathname (car file)) (fs:parse-pathname file)))
	(properties (if (consp file) (cdr file))))
    (with-open-file (instream pathname :direction :input
			      :characters (or (getf properties :characters) :default))
      (unless properties
	(setq properties (send instream :plist)))
      (block write-file
	(unless silent
	  (format t "~&Writing file: ~a" pathname))
	(Setq current-plist nil)
	(let ((props (check-plist-validity (or properties (send instream :plist))))
	      (byte-factor (/ (file-byte-size instream) 8))
	      (chunk-size (floor (send device :optimal-chunk-size record-size) record-size))
	      (truename (send instream :truename))
	      number-of-records
	      last-record-fill)
	  (condition-case (condition)
	      (send self :write-file-header device truename props)
	    (physical-end-of-tape
	     (ecase end-of-tape-action
	       (:error
		(signal 'end-of-tape-writing-header
		   :file-plist (cons nil props)
		   :device device))
	       (:continue
		(setq tape-modified nil)
		(Get-Next-Tape
		  "Physical end of tape.  Continue on next tape.  Unloading..." self device)
		(send self :write-file-header device truename props))
	       (:return
		(return-from write-file
		  (make-condition 'end-of-tape-writing-header
				  :file-plist (cons nil props)
				  :device device))))))
	  (using-resource (buffer si:dma-buffer (* chunk-size (/ record-size *bytes-per-page*)))
	    (multiple-value-bind (a b)
		(floor (* (send instream :length) byte-factor) record-size)
	      (setq number-of-records (if (zerop b) a (add1 a))
		    last-record-fill (/ (if (zerop b) record-size b) byte-factor)))
	    (do* ((record-count 0)
		  (rs (/ record-size byte-factor))
		  (records-this-pass (min (- number-of-records record-count) chunk-size)
				     (min (- number-of-records record-count) chunk-size))
		  (last-bunch (<= (- number-of-records record-count) chunk-size)
			      (<= (- number-of-records record-count) chunk-size))
		  (buffer-array (ecase byte-factor
				  (1 (si:dma-buffer-8b buffer))
				  (2 (si:dma-buffer-16b buffer)))))
		 ((= record-count number-of-records)
		  (condition-case (condition)
		      (send device :write-filemark)
		    (physical-end-of-tape))
		  t)
	      (send instream :string-in nil buffer-array 0
		    (if (not last-bunch)
			(* records-this-pass rs)
		      ;; stupid format lossage
		      (array-initialize buffer-array 0
					(+ (* (sub1 records-this-pass) rs) last-record-fill)
					(* records-this-pass rs))
		      (+ (* (sub1 records-this-pass) rs) last-record-fill)))
	      (condition-case (condition)
		  (send device :write-array buffer-array records-this-pass record-size)
		(physical-end-of-tape
		 (ecase end-of-tape-action
		   ((:error :return)
		    (let ((cond (make-condition
				 'end-of-tape-writing-file
				   :file-plist (cons nil props)
				   :device device
				   :bytes-transferred
				      (* (+ record-count (send condition :data-transferred)) rs))))
		      (case end-of-tape-action
			(:return (return-from write-file cond))
			(:error (signal cond)))))
		   (:continue
		    (setq tape-modified nil)
		    (Get-Next-Tape
		      "Physical end of tape encountered.  Continue on next tape.  Unloading..." self device)
		    (let ((records-written (send condition :data-transferred)))
		      (format t "~&Writing continuation header...")
		      (send self :write-file-header
			    device
			    (fs:parse-pathname "lm:continuation.file#0")
			    (let ((bytes-left (- (or (send-if-handles instream :length-in-bytes)
						     (send instream :length))
						 (* (+ record-count records-written) rs))))
			      (list :byte-size (file-byte-size props)
				    :length-in-bytes bytes-left
				    :length-in-blocks (ceiling (* bytes-left byte-factor)
							       *bytes-per-page*)
				    :continuation-properties props)))
		      (format t "written.")
		      (using-resource
			  (temp-buffer si:dma-buffer (* (- records-this-pass records-written)
							(/ rs *bytes-per-page*)))
			(copy-array-portion
			  buffer-array (* records-written rs) (* records-this-pass record-size)
			  (case byte-factor
			    (1 (si:dma-buffer-8b temp-buffer))
			    (2 (si:dma-buffer-16b temp-buffer)))
			  0
			  (* (- records-this-pass records-written) rs))
			(format t "~&Writing partial record data...")
			(send device :write-array
			      (si:dma-buffer-8b temp-buffer)
			      (- records-this-pass records-written)
			      record-size)
			(format t "written."))
		      (incf record-count records-this-pass)))))
		(:no-error
		 (incf record-count records-this-pass)))))))))
  )

;;; Need to do a better job than this. (properties may be in a different order, etc.)
(defun continuation-properties-equal (plist cplist)
  (equalp (get cplist :continuation-properties) plist))


(defmethod (lmfl-format :find-continuation-tape) (device plist)
  (check-device device)
  (check-plist plist)
  (do () (nil)
    (prompt-for-new-tape self device)
    (let ((cplist (send self :read-file-header device)))
      (if (continuation-properties-equal plist cplist)
	  (return t)
	(When (yes-or-no-p
		"The current tape does not appear to be a continuation of the last tape.  Use it anyway?")
	      (return t)))))
  )


(defmethod (lmfl-format :compare-partition) (device plist silent)
  (check-device device)
  (check-plist plist)
  (let ((part-disk-unit (get plist :host-unit))
	(part-host (or (condition-case ()
			   (si:parse-host (get plist :host))
			 (si:unknown-host-name))
		       si:local-host))
	(plist-name (get plist :name)))
    (multiple-value-bind (host unit start length nil name)
	(partition-searcher
	  (format nil "for comparing ~s" plist-name)
	  (get plist :size)
	  :default-partition (typecase plist-name
			       ((or string null) plist-name)
			       (t nil))
	  :default-unit (if (eq (si:parse-host part-host) si:local-host)
			    part-disk-unit
			  (format nil "~A ~D" part-host part-disk-unit))
	  :default-comment (get plist :comment))
      (if (null host)
	  (progn (format t "~&*** User aborted comparison of partition: ~a ***"
			 (or (get plist :comment) (get plist :name)))
		 (send self :space-to-end-of-this-file device plist 0))
	(do ((first start)
	     (blocks (or (si:measured-from-part-size unit name start length) length))
	     Result
	     finished?)
	    (finished? result)
	  (condition-case (condition)
	      (setq result (send device :compare-to-disk
				 unit first blocks record-size :silent silent))
	    (physical-end-of-tape
	     (format t "~&Partition continued on another tape.  Unloading this tape...")
	     (send device :rewind)
	     (send device :unload)
	     (prompt-for-new-tape self device)
	     (Let ((data-transferred (send condition :data-transferred)))
	       (incf first data-transferred)
	       (decf blocks data-transferred)))
	    (:no-error
	     (setq finished? t)
	     (if result
		 (condition-case ()
		     (send device :space 1)
		   ((physical-end-of-tape filemark-encountered)
		    (signal 'logical-end-of-tape :device-object device)))
	       (do (finished?)
		   (finished?)
		 (condition-case (condition)
		     (send device :search-filemark 1 :high)
		   (physical-end-of-tape
		    (prompt-for-new-tape self device))
		   (:no-error (setq finished? t))))))))))))


(defmethod (lmfl-format :compare-file) (device &key transform silent (error-action :return))
  (check-device device)
  (let* ((pl (send self :read-file-header device si:local-host))
	 (max-chunk (send device :optimal-chunk-size record-size))
	 (pathname (if transform
		       (process-transform transform pl)
		     (car pl)))
	 (length-in-bytes (or (get pl :length-in-bytes)
			      (get pl :length)
			      (get pl :size)	; for partitions
			      (ferror nil "length in bytes is NIL!")))
	 (byte-factor (/ (file-byte-size pl) 8))
	 number-of-chunks
	 last-chunk-size)
    (setq current-plist nil)
    (if (get pl :partition)
	(send self :compare-partition device pl silent)
      (if (not (condition-case (cond)
		   (probef pathname)
		 (fs:directory-not-found)))
	  (let ((cond (make-condition 'compare-source-not-found :source-file pathname)))
	    (send self :space-to-end-of-this-file device pl 0)
	    (case error-action
	      (:return
	       (unless silent
		 (format t "~&File \"~a\" not found for comparison" pathname))
	       cond)
	      (:error (signal-condition cond))))
	(block really-compare
	  (multiple-value-bind (a b)
	      (floor (* length-in-bytes byte-factor) max-chunk)
	    (setq number-of-chunks (if (zerop b) a (add1 a))
		  last-chunk-size (if (zerop b) max-chunk b))
	    (with-open-file (f pathname
			       :direction :input
			       :characters :default)
	      (using-resource (fbuffer si:dma-buffer (/ max-chunk *bytes-per-page*))
		(using-resource (tbuffer si:dma-buffer (/ max-chunk *bytes-per-page*))
		  (unless silent
		    (format t "~&Comparing \"~a\" ... " pathname))
		  (unless (and (= length-in-bytes
				  (or (get f :length-in-bytes)
				      (get f :length)
				      (ferror nil "file's length in bytes is NIL!")))
			       (= (file-byte-size pl) (file-byte-size f))
			       (= (get pl :creation-date) (get f :creation-date))
			       (eq (get pl :characters) (get f :characters)))
		    (let ((cond (make-condition 'compare-source-changed
						:source-plist (cons (send f :truename)
								    (plist f))
						:file-plist pl)))
		      (unless silent
			(format t "[*** Not Compared ***]"))
		      (send self :space-to-end-of-this-file device pl 0)
		      (case error-action
			(:return (return-from really-compare cond))
			(:error (signal-condition cond)))))
		  (when (zerop length-in-bytes)
		    (send device :space 1)
		    (Setq current-plist nil)
		    (format t "[Zero Length]")
		    (return-from really-compare pl))
		  (do* ((count 0 (add1 count))
			(records-compared 0)
			(bytes-this-time	;note these are 8-bit bytes
			  (if (= count (sub1 number-of-chunks)) last-chunk-size max-chunk)
			  (if (= count (sub1 number-of-chunks)) last-chunk-size max-chunk))
			(farray (case byte-factor
				  (1 (si:dma-buffer-8b fbuffer))
				  (2 (si:dma-buffer-16b fbuffer))))
			(fstring (si:dma-buffer-string fbuffer))
			(tstring (si:dma-buffer-string tbuffer))
			unequalp)
		       ((or (= count number-of-chunks) unequalp)
			(if unequalp
			    (let ((cond (make-condition 'compare-error
							:source-file (send f :truename)
							:file-plist pl)))
			      (unless silent
				(format t "[*** Unequal ***]"))
			      (ecase error-action
				(:return
				 (send self :space-to-end-of-this-file device pl records-compared)
				 cond)
				(:error (signal-condition cond))))
			  (unless silent
			    (format t "[Equal]"))
			  (Setq current-plist nil)
			  (condition-case (condition)
			      (send device :space 1)
			    (physical-end-of-tape))
			  pl))
		    (send f :string-in nil farray 0 (/ bytes-this-time byte-factor))
		    (Setq current-plist nil)
		    (condition-case (condition)
			(send device :read-array
			      tstring (ceiling bytes-this-time record-size) record-size)
		      (physical-end-of-tape
		       (let* ((records-read (send condition :data-transferred))
			      (bytes-left (- bytes-this-time (* records-read record-size))))
			 (format t "~&File continued on another tape.  Unloading...")
			 (send device :rewind)
			 (send device :unload)
			 (send self :find-continuation-tape device pl)
			 (if (string-not-equal fstring tstring
					       :end1 (- bytes-this-time bytes-left)
					       :end2 (- bytes-this-time bytes-left))
			     (setq unequalp t
				   records-compared (+ records-compared records-read))
			   (send device :read-array
				 tstring (ceiling bytes-left record-size) record-size)
			   (unless (string-equal fstring tstring
						 :Start1 (- bytes-this-time bytes-left)
						 :end1 bytes-this-time
						 :end2 bytes-left)
			     (setq unequalp t))
			   (incf records-compared (ceiling bytes-this-time record-size)))))
		      (:no-error
		       (unless (string-equal fstring tstring
					     :start1 0
					     :end1 bytes-this-time
					     :Start2 0
					     :end2 bytes-this-time)
			 (setq unequalp t
			       records-compared
			       (ceiling bytes-this-time record-size)))))))))))))))


(defmethod (lmfl-format :beginning-of-file) (device)
  (check-device device)
  (Setq current-plist nil)
  (condition-case ()
      (send device :search-filemark-reverse 1 :high)
    (physical-beginning-of-tape)))


(defmethod (lmfl-format :next-file) (device &optional (nfiles 1))
  (check-device device)
  (check-type nfiles (integer 1))
  (Setq current-plist nil)
  (dotimes (c nfiles) 
    (send device :search-filemark 1 :high)))


(defmethod (lmfl-format :previous-file) (device &optional (nfiles 1))
  (check-device device)
  (check-type nfiles (integer 1))
  (send self :beginning-of-file device)
  (dotimes (times nfiles)
    (send device :space-reverse 1)
    (send device :search-filemark-reverse 1 :high)))


(defmethod (lmfl-format :find-file) (device match)
  (check-device device)
  (check-type match (or list compiled-function closure symbol string pathname))
  (do ((pl (send self :read-file-header device si:local-host)
	   (send self :read-file-header device si:local-host)))
      ((tape-file-match match pl)
       pl)
    (send self :space-to-end-of-this-file device pl 0)))


(defmethod (lmfl-format :find-file-reverse) (device match)
  (check-device device)
  (check-type match (or list compiled-function closure symbol string pathname))
  (send self :beginning-of-file device)
  (send self :previous-file device)
  (do ((pl (send self :read-file-header device si:local-host)
	   (send self :read-file-header device si:local-host)))
      ((tape-file-match match pl)
       pl)
    (send self :beginning-of-file device)
    (send self :previous-file device)))


(defmethod (lmfl-format :open-file) (device &key
				     (direction :input)
				     (byte-size :default)
				     (characters :default)
				     plist)
  (check-device device)
  (check-type direction (member :input :output))
  (check-type byte-size (member 8 16 :default))
  (check-type characters (member :default t nil))
  (when (eq direction :output)
    (check-plist plist))
  (when file-stream
    (case (send file-stream :status)
      ((:bof :closed))
      (t (close file-stream :abort t))))
  (when (and (eq direction :output) (null plist))
    (signal 'protocol-violation
	    :format-string "LMFL Output stream must have a plist."))
  (let* ((pl (if (eq direction :input) (send self :read-file-header device) plist))
	 (*characters (if (eq characters :default)
			  (get pl :characters)
			(setf (get plist :characters) characters)))
	 (*byte-size (if (eq byte-size :default)
			 (file-byte-size pl)
		       (setf (get pl :byte-size) byte-size))))
    (send device :lock-device)
    (when (eq direction :output)
      (send self :write-file-header device (car pl) (cdr pl)))
    (setq tape-modified (eq direction :output)
	  file-stream (make-instance (case direction
				       (:input (if (not *characters)
						   'lmfl-input-stream
						 'lmfl-input-character-stream))
				       (:output (if (not *characters)
						    'lmfl-output-stream
						  'lmfl-output-character-stream)))
				     :device device
				     :byte-size *byte-size
				     :record-size record-size
				     :format self
				     :pathname (car pl)
				     :property-list (cdr pl)))))
		 
(defmethod (lmfl-format :list-files) (device &key (stream *standard-output*) (number-of-files -1))
  (check-device device)
  (check-type number-of-files (integer))
  (let (list)
    (condition-case ()
	(do (plist
	     byte-size
	     (count 0 (add1 count)))
	    ((= count number-of-files) (reverse list))
	  (setq plist (send self :read-file-header device)
		byte-size (file-byte-size plist))
	  (push plist list)
	  (when stream
	    (if (get plist :partition)
		(format stream "~&Partition: \"~A\" - Length in Blocks: ~D"
			(or (get plist :comment) "Unknown")
			(get plist :size))
	      (format stream "~&~A ~50TByte Size: ~D ~65T- Length in bytes: ~D"
		      (car plist)
		      byte-size
		      (or (get plist :length-in-bytes)
			  (get plist :length)))))
	  (send self :space-to-end-of-this-file device plist 0))
      (logical-end-of-tape
       (Condition-Case ()
	   (send device :space-reverse 1)
	 (driver-error))
       (reverse list)))))

(defmethod (lmfl-format :finish-tape) (device)
  (check-device device)
  (when tape-modified
    (condition-case ()
	(send device :write-filemark)
      (physical-end-of-tape)
      (:no-error
       (Condition-Case ()
	   (send device :space-reverse 1)
	 (driver-error))))
    (setq tape-modified nil)))

(defmethod (lmfl-format :rewind) (device &optional (wait-p t))
  (when file-stream
    (close file-stream :abort t)
    (setq file-stream nil))
  (when tape-modified
    (case (prompt-for-rewind-with-state)
      (:resume (setq tape-modified nil))
      (:save-state (send self :finish-tape device))
      (:enter-debugger
       (ferror nil "Tape state not saved (debug request by user)"))))
  (Setq current-plist nil)
  (send device :rewind wait-p))

(defmethod (lmfl-format :unload) (device)
  (when file-stream
    (close file-stream :abort t)
    (setq file-stream nil))
  (when tape-modified
    (case (prompt-for-rewind-with-state)
      (:resume (setq tape-modified nil))
      (:save-state (send self :finish-tape device))
      (:enter-debugger
       (ferror nil "Tape state not saved (debug request by user)"))))
  (Setq current-plist nil)
  (send device :unload))

(defmethod (lmfl-format :position-to-append) (device)
  (check-device device)
  (Setq current-plist nil)
  (send device :search-filemark 2 :high)
  (send device :space-reverse 1))

(compile-flavor-methods lmfl-format)

(define-tape-format lmfl-format "lmfl")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; LMFL File streams
;;;

(defflavor lmfl-input-mixin () (tape-stream-mixin))

(defmethod (lmfl-input-mixin :close) (&optional abort-p)
  (unless (eq status :closed)
    (unless (or abort-p (eq status :eof))
      (send device :search-filemark 1))
    (setq status :closed)
    (when dma-buffer
      (deallocate-resource 'si:dma-buffer dma-buffer))
    (setq dma-buffer nil
	  io-buffer nil)
    (send device :unlock-device)))

(defflavor lmfl-input-character-stream ()
	   (lmfl-input-mixin si:buffered-input-character-stream))

(defflavor lmfl-input-stream ()
	   (lmfl-input-mixin si:buffered-input-stream))

(compile-flavor-methods lmfl-input-character-stream lmfl-input-stream)

;;;;;;;;;;;;;;;;;;;;

(defflavor lmfl-output-mixin () (tape-stream-mixin))

(defmethod (lmfl-output-mixin :close) (&optional abort-p)
  (unless (eq status :closed)
    (setq status :closed)
    (unless abort-p
      (send self :force-output)
      (send device :write-filemark))
    (when dma-buffer
      (deallocate-resource 'si:dma-buffer dma-buffer))
    (setq dma-buffer nil
	  io-buffer nil)
    (send device :unlock-device)))

(defflavor lmfl-output-stream ()
	   (lmfl-output-mixin si:buffered-output-stream))

(defflavor lmfl-output-character-stream ()
	   (lmfl-output-mixin si:buffered-output-character-stream))

(compile-flavor-methods lmfl-output-stream lmfl-output-character-stream)

))