;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for CDI version 1.7
;;; Reason:
;;;  NuPI tape device support and LMFL format modifications (for NuPI).
;;; Written 16-May-86 12:43:27 by PTM at site LMI Cambridge
;;; while running on Larry from band 2
;;; 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, Gateway 4.15, 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.29, Experimental Window-Maker 2.0, Experimental NVRAM 8.0, Experimental CDI 1.6, microcode 1512, SDU ROM 103, Alpha VI.



; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:43:28
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

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

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:43:39
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

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

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:44:08
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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
	   (if (= (send condition :data-transferred) (sub1 records-to-space-over))	
	       ;if end of tape is where filemark would be ignore it for now
	       t
	     (format *standard-output* "~&File continued on next tape.  Unloading this tape.")
	     (send self :rewind device)
	     (send self :unload device)
	     (send self :find-continuation-tape device plist)
	     (incf passed (send condition :data-transferred))
	     nil))))))
))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:44:20
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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))
	(Setq current-plist nil)
	(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))))))))))))
  )
))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:44:33
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(defmethod (lmfl-format :restore-partition) (plist device silent)
  (check-plist plist)
  (check-device device)
  (let ((size (get plist :size))
	(comment (or (get plist :comment) "??? From tape")))
    (multiple-value-bind (host unit start length label name)
	(When (yes-or-no-p "Restore Partition ~S? " (or (get plist :comment)
							(get plist :name)))
	  (partition-searcher "for writing" (get plist :size)
	     :confirm-write t :default-unit tframe:*default-disk-unit*)) ;; +++
      label length ; not used
      (unwind-protect
	  (if (null host)
	      (progn 
		(format t "~&*** User Aborted restoring partition: ~A ***"
			(or (get plist :comment)
			    (get plist :name)))
		(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
		 (format *standard-output*
			 "Partition continued on another tape.  Unloading this one.")
		 (send self :unload device)
		 (prompt-for-new-tape self device)
		 (incf first-block (send condition :data-transferred))
		 (decf blocks (send condition :data-transferred)))
		(:no-error
		 (si:update-partition-comment name comment unit)
		 (condition-case (condition)
		     (send device :space 1)
		   (physical-end-of-tape))
		 (setq finished? t)))))
	(when unit (si:dispose-of-unit unit))))))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:44:46
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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)
			   (* si:page-size 4)))
	(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 *standard-output*
			     "~&Tape continued on another tape.  Unloading this tape.")
		     (send self :rewind device)
		     (send self :unload device)
		     (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))))))))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:44:59
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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))))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:45:08
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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))
  (setq tape-modified t)
  (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))
	  (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)
		(send device :write-from-disk
		      unit addr blocks-to-write record-size :silent silent)
	      (physical-end-of-tape
	       (let ((blocks-left (- blocks-to-write (send condition :data-transferred))))
		 (format t "~&End of tape during partition. Unloading tape...")
		 (send device :unload)
		 (setq addr (+ addr (send condition :data-transferred))
		       blocks-to-write blocks-left)
		 (prompt-for-new-tape self device)))
	      (:no-error
	       (setq blocks-to-write 0)
	       (condition-case ()
		   (send device :write-filemark)
		 (physical-end-of-tape))))))))))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:45:21
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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 *standard-output* "~&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))
	      number-of-records
	      last-record-fill)
	  (condition-case (condition)
	      (send self :write-file-header device (send instream :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)
			  (send device :unload)
			  (prompt-for-new-tape self device)
			  (send self :write-file device pathname
				:end-of-tape-action end-of-tape-action
				:silent silent))
	       (: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 si:page-size 4)))
	    (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
		    (format *standard-output*
			    "~&Physical end of tape encountered. Will Continue on next tape.~%~
                                 Unloading this tape.")
		    (setq tape-modified nil)
		    (send self :rewind device)
		    (send device :unload)
		    (prompt-for-new-tape self device)
		    (send self :write-file-header
			  device
			  (fs:parse-pathname "lm:continuation.file#0")
			  (let ((bytes-left (- (or (send instream :length-in-bytes)
						   (send instream :length))
					       (* (+ record-count
						     (send condition :data-transferred))
						  rs))))
			    (list :byte-size (file-byte-size props)
				  :length-in-bytes bytes-left
				  :length-in-blocks (ceiling (* bytes-left byte-factor)
							     (* si:page-size 4))
				  :continuation-properties props)))
		    (let ((records-written (send condition :data-transferred)))
		      (using-resource (temp-buffer
					si:dma-buffer (* (- records-this-pass records-written)
							 (/ rs (* si:page-size 4))))
			(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))
			(send device :write-array
			      (si:dma-buffer-8b temp-buffer)
			      (- records-this-pass records-written)
			      record-size))))))
		(:no-error (incf record-count records-this-pass))))))))))
))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:45:40
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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")
	  (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))
      (Setq current-plist nil)
      (if (null host)
	  (progn (format *standard-output* "~&*** 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
	     (send device :unload)
	     (format t "~&Partition continued on another tape.")
	     (prompt-for-new-tape self device)
	     (incf first (send condition :data-transferred))
	     (decf blocks (send condition :data-transferred)))
	    (:no-error
	     (setq finished? t)
	     (if result
		 (condition-case ()
		     (send device :space 1)
		   (physical-end-of-tape
		    (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))))))))))))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:45:52
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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)
    (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 *standard-output*
			 "~&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 (* si:page-size 4)))
		(using-resource (tbuffer si:dma-buffer (/ max-chunk (* si:page-size 4)))
		  (unless silent
		    (format *standard-output*
			    "~&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 *standard-output* "[*** 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)
		    (format *standard-output* "[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 *standard-output* "[*** 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 *standard-output* "[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))))
			 (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)))))))))))))))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:46:14
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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)))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:47:26
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "


(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)))

))

; From file DJ: L.TAPE; LMFL-FORMAT.LISP#188 at 16-May-86 12:48:06
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  "

(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)

))

; From file DJ: L.TAPE; NUPI-SUPPORT.LISP#7 at 16-May-86 12:48:29
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-SUPPORT  "

(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 DJ: L.TAPE; NUPI-SUPPORT.LISP#7 at 16-May-86 12:48:34
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-SUPPORT  "

(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))
  )

))

; From file DJ: L.TAPE; NUPI-SUPPORT.LISP#7 at 16-May-86 12:48:44
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-SUPPORT  "


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

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

))

; From file DJ: L.TAPE; NUPI-SUPPORT.LISP#7 at 16-May-86 12:49:40
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-SUPPORT  "


(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 wait-for-nupi-command (command-block)
  (process-wait "Tape Wait" #'NuPI-Command-Complete-P command-block)
  (When (NuPI-Command-Error-P command-block)
    (ferror nil "nupi error")))

(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)))

))

; From file DJ: L.TAPE; NUPI-SUPPORT.LISP#7 at 16-May-86 12:49:54
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-SUPPORT  "

(defun simple-nupi-command (command-block command logical-unit disk-address byte-count
			    dma-buffer dma-buffer-offset-in-pages
			    set-modified)
  (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)
  (finish-nupi-command command-block dma-buffer))

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:50:23
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

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

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:50:35
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

(defmethod (nupi-device :space) (number-of-records &optional (speed :low))
  (check-type number-of-records (integer 1))
  (check-type speed (member :high :low))
  ;; kludge this for now, using the last transfer count, assuming that is the record
  ;; size. But q? Isnt the tape record oriented?

  ;; Convert from LMFL (4096 byte) blocks to NuPI (1024 byte) blocks.
  (Let ((number-of-blocks (/ (* number-of-records 4096.) 1024.)))
    (si:simple-nupi-command command-block
			    #x23
			    unit
			    0
			    4.
			    number-of-blocks
			    0
			    nil))
  )

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:50:41
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

(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.")
  )

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:50:44
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

(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)
  )

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:50:48
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

(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.")
  )

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:51:18
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "


(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))))
    (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."))))))))

(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))))
    (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)))))

(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 120 number-of-blocks))
	 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)))
    (using-resource (buffer si:dma-buffer chunk-size)
      (using-resource (disk-command-block si:dma-buffer 1)
	;; +++ Kwik Kludge (tm) to make dma buffer into a NuPI command block +++
	(setf (si:dma-buffer-named-structure-symbol disk-command-block) 'si:nupi-command-block)
	(with-buffer-wired (buffer chunk-size)
	  (Unless silent
	    (format t "~&Operation will take ~d transfers:" number-of-chunks))
	  (do ((count 1 (add1 count))
	       (address starting-block (+ address chunk-size)))
	      ((> count number-of-chunks))
	    (When (= count number-of-chunks)
	      (Setq chunk-size last-chunk-size))
	    (Unless silent (format t " ~d" count))
	    (si:nupi-read-from-disk
	      disk-command-block disk-unit address (* chunk-size si:page-size 4) buffer 0)
	    (si:nupi-write-to-tape
	      command-block unit 0 (* chunk-size si:page-size 4) buffer 0))))))
  )


(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 120 number-of-blocks))
	 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)))
    (using-resource (tape-buffer si:dma-buffer chunk-size)
      (using-resource (disk-buffer si:dma-buffer chunk-size)
	(using-resource (disk-command-block si:dma-buffer 1)
	  ;; +++ Kwik Kludge (tm) to make dma buffer into a NuPI command block +++
	  (setf (si:dma-buffer-named-structure-symbol disk-command-block) 'si:nupi-command-block)
	  (with-buffer-wired (tape-buffer chunk-size)
	    (with-buffer-wired (disk-buffer chunk-size)
	      (do ((count 1 (add1 count))
		   (address starting-block (+ address chunk-size))
		   error-list)
		  ((> count number-of-chunks) (reverse error-list))
		(When (= count number-of-chunks)
		  (Setq chunk-size last-chunk-size))
		(si:nupi-read-from-disk
		  disk-command-block disk-unit address (* chunk-size si:page-size 4) disk-buffer 0)
		(si:nupi-read-from-tape
		  command-block unit 0 (* chunk-size si:page-size 4) tape-buffer 0)
		(let ((val (string-compare (si:dma-buffer-string disk-buffer)
					   (si:dma-buffer-string tape-buffer))))
		  (if (zerop val)
		      (Unless silent (write-char #\.))
		    (push (cons count address) error-list)
		    (format *error-output* "~& Error in record number ~d; Byte: ~D"
			    count (abs val))))))))))
    (if error-list (reverse 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 120 number-of-blocks))
	 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)))
    (using-resource (buffer si:dma-buffer chunk-size)
      (using-resource (disk-command-block si:dma-buffer 1)
	;; +++ Kwik Kludge (tm) to make dma buffer into a NuPI command block +++
	(setf (si:dma-buffer-named-structure-symbol disk-command-block) 'si:nupi-command-block)
	(with-buffer-wired (buffer chunk-size)
	  (Unless silent
	    (format t "~&Operation will take ~d transfers:" number-of-chunks))
	  (do ((count 1 (add1 count))
	       (address starting-block (+ address chunk-size)))
	      ((> count number-of-chunks))
	    (When (= count number-of-chunks)
	      (Setq chunk-size last-chunk-size))
	    (Unless silent (format t " ~d" count))
	    (si:nupi-read-from-tape
	      command-block unit 0 (* chunk-size si:page-size 4) buffer 0)
	    (si:nupi-write-to-disk
	      disk-command-block disk-unit address (* chunk-size si:page-size 4) buffer 0))))))
  )

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:51:23
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

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

))

; From file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:51:31
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

(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))
  )

))

; From modified file DJ: L.TAPE; NUPI-DEVICE.LISP#12 at 16-May-86 12:52:28
#10R TAPE#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; NUPI-DEVICE  "

(compile-flavor-methods nupi-device)
))