;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for CDI version 1.13
;;; Reason:
;;;  Tape support fixes since last patch.
;;; Written 9-Jul-86 16:20:32 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.12, microcode 1525, CDI LambdaE base.



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


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

))

; From file S2: >Lambda-3>TAPE>NUPI-DEVICE.LISP.31 at 9-Jul-86 16:24:24
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; nupi-device lisp "


(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.)))
    (si:simple-nupi-command
      command-block #x23 unit 0 4 number-of-blocks 0 nil "Tape Space"))
  )



))

; From file S2: >Lambda-3>TAPE>NUPI-DEVICE.LISP.31 at 9-Jul-86 16:24:25
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; nupi-device lisp "


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


))

; From file S2: >Lambda-3>TAPE>tape.lisp.160 at 9-Jul-86 16:24:29
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; TAPE  "


(defconst *16-bit-file-canonical-types* '("QFASL" "EMC" "LMC" "XFASL" "BIN"))

))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:38
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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 *bytes-per-page*))
      (send device :read-block header-block record-size)
      (string-equal "LMFL" (si:dma-buffer-string header-block) :end2 4))
    (send self :rewind device)))


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:42
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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) *bytes-per-page*)
			   (* (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)
	     (condition-case ()
		 (send device :search-filemark 1 :high)
;;		 (send device :space records-to-space-over
;;		       (if (> (* records-to-space-over record-size)
;;			      (send device :speed-threshold record-size))
;;			   :high
;;			 :low))
	       (tape:filemark-encountered ))
	     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
	       (send self :find-continuation-tape device plist)
	       (incf passed data-transferred)
	       nil))))))
  )


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:45
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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 *bytes-per-page*))
	(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 S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:46
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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 :search-filemark 1 :high)
		   (physical-end-of-tape))
		 (setq finished? t)))))
	(when unit (si:dispose-of-unit unit))))))


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:47
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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)))
    (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))
		     (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)
	      ((filemark-encountered physical-end-of-tape)))))))))


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:49
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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 *bytes-per-page*))
      (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 S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:50
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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 *bytes-per-page*))
	(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 (* (ceiling (- end start) 4.) 4)))
	    ((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))))))))))


))

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


(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)
	  ;; +++ kludge to indicate byte size actually used to write the file to tape +++
	  (nconc props (list :byte-size (file-byte-size instream)))
	  (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)))
		      (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)))
		      (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))
			(send device :write-array
			      (si:dma-buffer-8b temp-buffer)
			      (- records-this-pass records-written)
			      record-size))
		      (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.)

))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:52
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(defmethod (lmfl-format :find-continuation-tape) (device plist)
  (check-device device)
  (check-plist plist)
  (tv:beep)
  (format t "~&Continued on another tape.  Unloading this tape...")
  (send device :rewind)
  (send device :unload)
  (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)))))
  )


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:54
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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" (get plist :comment))
	  (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))))))))))))


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:55
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(defmethod (lmfl-format :compare-file) (device &key transform silent (error-action :return))
  (check-device device)
  (let* ((pl (send self :read-file-header device))
	 (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 ***]")
;;;			(Unless (= length-in-bytes
;;;				   (or (get f :length-in-bytes)
;;;				       (get f :length)))
;;;			  (format t " -- length not equal"))
;;;			(Unless (= (file-byte-size pl) (file-byte-size f))
;;;			  (format t " -- byte size not equal"))
;;;			(Unless (= (get pl :creation-date) (get f :creation-date))
;;;			  (format t " -- creation date not equal"))
;;;			(Unless (eq (get pl :characters) (get f :characters))
;;;			  (format t " -- characters attribute not equal"))
			)

		      (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)
		    (Setq current-plist nil)
		    (condition-case (condition)
			(send device :space 1)
		      ((filemark-encountered physical-end-of-tape)))
		    (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)
			    ((filemark-encountered 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 S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:57
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


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


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:24:58
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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)
	   (send self :read-file-header device)))
      ((tape-file-match match pl)
       pl)
    (send self :space-to-end-of-this-file device pl 0)))


))

; From file S2: >Lambda-3>TAPE>lmfl-format.LISP.198 at 9-Jul-86 16:25:02
#10R TAPE#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: tape; LMFL-FORMAT lisp "


(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)
	   (send self :read-file-header device)))
      ((tape-file-match match pl)
       pl)
    (send self :beginning-of-file device)
    (send self :previous-file device)))


))