;;; -*- Mode: Common-Lisp; Package: MT; Base: 10.; Patch-File: T -*- ;;; Patch file for STREAMER-TAPE version 6.1 ;;; Reason: Fixed stream-data-copy and verify-partition to handle EOM. ;;; Written 06/12/89 07:23:01 by BERGER, ;;; while running on ARIES from band LOD1 ;;; With SYSTEM 6.5, VIRTUAL-MEMORY 6.1, EH 6.1, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.1, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.2, TV 6.6, DATALINK 6.0, CHAOSNET 6.0, GC 6.2, MEMORY-AUX 6.0, NVRAM 6.0, ;;; SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0, ;;; DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.1, TI-CLOS 6.5, CLEH 6.1, IP 3.46, ;;; Experimental BUG 11.7, CLX 6.0, CLUE 6.0, X11M 6.0, microcode 429, Band Name: Release 6.0 + SLE 5/22 #!C ; From file PART-STREAM.LISP#> STREAMER-TAPE; SYS: #10R MT#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "MT")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: STREAMER-TAPE; PART-STREAM.#" (DEFUN STREAM-DATA-COPY (FROM-UNIT TO-UNIT START-UP-ADR FROM-END N-BUFFERS B-SIZE &OPTIONAL (OUT-STREAM *TERMINAL-IO*) (N-HUNDRED 0)) "This assumes that the to-unit address range has been checked !!!!!!" (LET ((FROM-REAL-UNIT (SI::GET-REAL-UNIT FROM-UNIT)) (OLD-PRIORITY (SEND CURRENT-PROCESS :PRIORITY)) (TO-REAL-UNIT (SI::GET-REAL-UNIT TO-UNIT)) (N-blocks-WRITTEN (* 100 N-HUNDRED)) (BUF-SIZE B-SIZE) (TO-ADR START-UP-ADR) FROM-Q TO-Q IDLE-Q completed?) (UNWIND-PROTECT (progn (SEND CURRENT-PROCESS :SET-PRIORITY *STREAMING-PRIORITY*) (LET (RQB) (DOTIMES (I N-BUFFERS) (SETQ RQB (SYSTEM:GET-DISK-RQB BUF-SIZE)) (SI::WIRE-NUPI-RQB RQB BUF-SIZE T T) (SI:nupi-read-wired rqb from-real-unit from-unit START-UP-ADR t) (PUSH-END RQB FROM-Q) (SETQ START-UP-ADR (+ START-UP-ADR BUF-SIZE)))) (DO* ((FROM-ADR START-UP-ADR)) ((>= FROM-ADR FROM-END)) ;end test (condition-case (condition) ; DAB 04-03-89 Trap for end-of-tape (DO ((RQB (CAR FROM-Q) (CAR FROM-Q))) ((OR (NULL RQB) ;q empty --> exit (NOT (SI::%IO-DONE RQB)))) ;io not done --> exit (IF (CHECK-FOR-ERROR-OR-STATUS RQB) (CERROR T () 'SI::TAPE ;proceedable "~&I/O error: ~A, on unit ~d." (SI::GET-LAST-ERROR FROM-UNIT) FROM-UNIT)) (POP FROM-Q) (SI:nupi-write-wired rqb to-real-unit to-unit to-adr t) ;turn it around (SETQ TO-ADR (+ TO-ADR BUF-SIZE)) (PUSH-END RQB TO-Q)) (error (if (or (search "END-OF-TAPE" (send condition :report-string)) ; DAB 04-03-89 Trap for end-of-tape (search "EOM" (send condition :report-string))) ; DAB 06-08-89 (setf completed? :END-OF-TAPE) (signal-condition condition))) ) ; condition-case (condition-case (condition) ; DAB 04-03-89 Trap for end-of-tape (DO ((RQB (CAR TO-Q) (CAR TO-Q))) ((OR (NULL RQB) ;q empty --> exit (NOT (SI::%IO-DONE RQB)))) ;io not done --> exit (CHECK-FOR-ERROR-OR-STATUS RQB) ;A write completed (SETQ N-blocks-WRITTEN (+ N-blocks-WRITTEN (Si:rqb-n-Blocks-Wired rqb))) ;count wired blocks (SETQ N-HUNDRED (MAYBE-DISPLAY-HUNDRED N-blocks-WRITTEN N-HUNDRED OUT-STREAM)) (SETQ RQB (POP TO-Q)) (LET ((AMT (MIN BUF-SIZE (- FROM-END FROM-ADR)))) ;Amount left to read (IF (ZEROP AMT) ;If tape blocks complete quickly at end,... (SYSTEM:RETURN-DISK-RQB RQB) ;We're done... So deallocate (PROGN (UNLESS (= AMT BUF-SIZE) ;ELSE keep going (SI::UNWIRE-DISK-RQB RQB) ;Left-over is less than rqb size, so wire partial. (SI::WIRE-NUPI-RQB RQB AMT T T)) (SI:nupi-read-wired rqb from-real-unit from-unit FROM-ADR t) (SETQ FROM-ADR (+ FROM-ADR AMT)) (PUSH-END RQB FROM-Q))))) (error ; DAB 04-03-89 Trap for end-of-tape (if (or (search "END-OF-TAPE" (send condition :report-string)) (search "EOM" (send condition :report-string))) ; DAB 06-08-89 (setf completed? :END-OF-TAPE) (signal-condition condition)))) (when (eq completed? :end-of-tape) (return())) ) ;DO* ; FINISH - now write out all remaining read buffers as they finish (unless (eq completed? :end-of-tape) ; DAB 04-03-89 (condition-case (condition) (DO ((RQB (CAR FROM-Q) (CAR FROM-Q))) ((NULL RQB)) (COND ((SI::%IO-DONE RQB) (IF (CHECK-FOR-ERROR-OR-STATUS RQB) (CERROR T () 'SI::TAPE ;proceedable "~&I/O error: ~A, on unit ~d." (SI::GET-LAST-ERROR FROM-UNIT) FROM-UNIT)) (POP FROM-Q) (SI:nupi-write-wired rqb to-real-unit to-unit to-adr t) (SETQ TO-ADR (+ TO-ADR (Si:rqb-n-Blocks rqb))) (PUSH-END RQB TO-Q)) (T (PROCESS-ALLOW-SCHEDULE)))) (error (if (or (search "END-OF-TAPE" (send condition :report-string)) ; DAB 04-03-89 (search "EOM" (send condition :report-string))) ; DAB 06-08-89 (setf completed? :END-OF-TAPE) (signal-condition condition)))) (condition-case (condition) ; DAB 04-03-89 Trap for end-of-tape (DO ((RQB (CAR TO-Q) (CAR TO-Q))) ((NULL RQB) :COMPLETE) (COND ((SI::%IO-DONE RQB) (CHECK-FOR-ERROR-OR-STATUS RQB) (SETQ N-blocks-WRITTEN (+ N-blocks-WRITTEN (Si:rqb-n-Blocks rqb))) (SETQ N-HUNDRED (MAYBE-DISPLAY-HUNDRED N-blocks-WRITTEN N-HUNDRED OUT-STREAM)) (POP TO-Q) (PUSH-END RQB IDLE-Q)) (T (PROCESS-ALLOW-SCHEDULE)))) (error (if (or (search "END-OF-TAPE" (send condition :report-string)) ; DAB 04-03-89 Trap for end-of-tape (search "EOM" (send condition :report-string))) ; DAB 06-08-89 (setf completed? :END-OF-TAPE) (signal-condition condition)))) ) (if (eq completed? :end-of-tape) ; DAB 04-03-89 Trap for end-of-tape (values :END-OF-TAPE N-HUNDRED) ;Yes, return :end-of-file :complete) ;No, return :complete ) ;progn (SEND CURRENT-PROCESS :SET-PRIORITY OLD-PRIORITY) (DEALLOCATE-Q FROM-Q OUT-STREAM) (DEALLOCATE-Q TO-Q OUT-STREAM) (DEALLOCATE-Q IDLE-Q OUT-STREAM) (SI::DISPOSE-OF-UNIT FROM-UNIT) (SI::DISPOSE-OF-UNIT TO-UNIT)))) (DEFUN VERIFY-PARTITION (DISK-UNIT DISK-PART &OPTIONAL (WHOLE-THING-P NIL) &KEY (BUF-SIZE 6) (N-BUFFERS 5) (OUT-STREAM *STANDARD-OUTPUT*) &AUX) "Compare partition DISK-PART on DISK-UNIT to partition on tape. N-buffer specifies how many buffers to allocate for per device; tape and disk." (let ((aborted-p T)) (proclaim '(special sys:%io-rq-leader-n-blocks)) (LET (DISK-PART-BASE DISK-PART-SIZE TO-PART-BASE TO-PART-SIZE RQB NO-ERRORS TO-UNIT STARTING-HUNDRED TAPE-RQB DISK-RQB TAPE-BUF DISK-BUF READ-COUNT TOTAL DISK-ADR-INIT TO-ADR-INIT IDLE-Q DISK-Q TAPE-Q MT-CLOSURE TAPE-REAL-UNIT DISK-REAL-UNIT partition-namestring cpu-type (error-message-queue ())) (SETQ TO-UNIT *CURRENT-UNIT*) (SETQ DISK-UNIT (SI::DECODE-UNIT-ARGUMENT DISK-UNIT (FORMAT () "reading ~A partition" DISK-PART))) (setq DISK-REAL-UNIT (SI::GET-REAL-UNIT DISK-UNIT)) (UNWIND-PROTECT (do () ((not (eq :eom-error ; DAB 03-21-89 handle end-of-tape error when user whats to continue. (catch 'eom-restart ; DAB 04-03-89 (setf tape-q nil disk-q nil idle-q nil error-message-queue nil) (setq MT-CLOSURE (SI::DECODE-UNIT-ARGUMENT "MT:" (FORMAT () "reading partition from tape unit ~d." TO-UNIT))) (SETQ TAPE-REAL-UNIT (SI::GET-REAL-UNIT TO-UNIT)) (SETQ NO-ERRORS T) (MULTIPLE-VALUE-SETQ (DISK-PART-BASE DISK-PART-SIZE nil nil nil partition-namestring) ;3/23/87 mp (SYSTEM:FIND-DISK-PARTITION-FOR-READ DISK-PART () DISK-UNIT)) (MULTIPLE-VALUE-SETQ (TO-PART-BASE TO-PART-SIZE) (SYSTEM:FIND-DISK-PARTITION-FOR-READ "" () MT-CLOSURE)) (ASSURE-PARTITION-OR-FERROR MT-CLOSURE) (SETQ STARTING-HUNDRED (OR (SEND MT-CLOSURE :GET :STARTING-OFFSET) 0)) (FORMAT OUT-STREAM "~&Comparing ~S and ~S" (SYSTEM:PARTITION-COMMENT partition-namestring DISK-UNIT) ;it was disk-part 3/23/87 mp (SYSTEM:PARTITION-COMMENT () MT-CLOSURE)) (UNLESS (ZEROP STARTING-HUNDRED) (FORMAT OUT-STREAM " starting at ~D. hundred Kbyte offset." STARTING-HUNDRED)) (SETQ TOTAL (- (+ TO-PART-BASE TO-PART-SIZE) (* 100 STARTING-HUNDRED))) (IF (< TOTAL (* N-BUFFERS BUF-SIZE)) (SETQ BUF-SIZE (MIN 96. (FLOOR TOTAL N-BUFFERS)))) (AND (STRING-EQUAL DISK-PART "LOD" :end1 3 :end2 3) (NOT WHOLE-THING-P) (LET ((RQB NIL) ) (UNWIND-PROTECT (PROGN (SETQ RQB (SYSTEM:GET-DISK-RQB sys:disk-blocks-per-page)) (LET ((SIZE (si:lod-partition-info rqb disk-unit disk-part-base))) (COND ((AND (> SIZE 8) (<= SIZE DISK-PART-SIZE)) (SETQ DISK-PART-SIZE SIZE) (FORMAT OUT-STREAM "... using measured size of ~D. blocks." SIZE))))) (SYSTEM:RETURN-DISK-RQB RQB)))) (SETQ TO-ADR-INIT (+ TO-PART-BASE (* 100 STARTING-HUNDRED))) (SETQ DISK-ADR-INIT (+ DISK-PART-BASE (* 100 STARTING-HUNDRED))) (ADDRESS-CHECK DISK-PART-BASE DISK-PART-SIZE partition-namestring DISK-ADR-INIT TOTAL) ;it was disk-part (SETQ READ-COUNT 0) (MULTIPLE-VALUE-SETQ (N-BUFFERS BUF-SIZE) (BUFFER-POOL-ADJUST DISK-PART-SIZE N-BUFFERS BUF-SIZE)) (DOTIMES (I N-BUFFERS) ;read tape stuff first (SETQ RQB (SYSTEM:GET-DISK-RQB BUF-SIZE)) (SI::WIRE-NUPI-RQB RQB BUF-SIZE T T) (SI:nupi-read-wired rqb tape-real-unit to-unit 0 T) (SETQ TO-ADR-INIT (+ TO-ADR-INIT BUF-SIZE)) (PUSH-END (LIST RQB (SYSTEM:RQB-8-BIT-BUFFER RQB)) TAPE-Q) ;now read disk stuff (SETQ RQB (SYSTEM:GET-DISK-RQB BUF-SIZE)) (SI::WIRE-NUPI-RQB RQB BUF-SIZE T T) (SI:nupi-read-wired rqb disk-real-unit disk-unit disk-adr-init T) (SETQ DISK-ADR-INIT (+ DISK-ADR-INIT BUF-SIZE)) (PUSH-END (LIST RQB (SYSTEM:RQB-8-BIT-BUFFER RQB)) DISK-Q) ;queues are list of '(rqb buffer) (SETQ READ-COUNT (+ READ-COUNT BUF-SIZE))) (DO ((DISK-ADR DISK-ADR-INIT) (TO-ADR TO-ADR-INIT) (DISK-HIGH (+ DISK-PART-BASE DISK-PART-SIZE)) (TO-HIGH (+ TO-PART-BASE TO-PART-SIZE)) (N-HUNDRED STARTING-HUNDRED) (L-hundred starting-hundred) ; DAB 04-03-89 (N-blocks-COMPARED (* STARTING-HUNDRED 100.)) ;9.2.87 MBC (DISK-HIGH-ADR (+ TO-PART-BASE TO-PART-SIZE))) ((>= N-blocks-COMPARED DISK-HIGH-ADR) (dolist (error-msg error-message-queue (setf error-message-queue ())) (format out-stream "~a" error-msg))) ;;;;;; WAIT FOR READS TO COMPLETE AND COMPARE BUFFERS (LET ((RQB-&-BUF (POP DISK-Q))) (SETQ DISK-RQB (CAR RQB-&-BUF)) ;get disk rqb (DO () ;no vars ((SI::%IO-DONE DISK-RQB) ;end-test (CHECK-FOR-ERROR-OR-STATUS DISK-RQB) (SETQ DISK-BUF (CADR RQB-&-BUF))) ())) ;no body (LET ((RQB-&-BUF (POP TAPE-Q))) (SETQ TAPE-RQB (CAR RQB-&-BUF)) ;get tape rqb (condition-case (condition) ; DAB 04-03-89 Handle end-of-tape errors. (DO () ;no vars ((SI::%IO-DONE TAPE-RQB) ;end-test (IF (CHECK-FOR-ERROR-OR-STATUS TAPE-RQB) (CERROR T () 'SI::TAPE ;proceedable "~&Tape error: ~A, on unit ~d." (SI::GET-LAST-ERROR TO-UNIT) TO-UNIT)) (SETQ TAPE-BUF (CADR RQB-&-BUF))) ()) (error (if (or (search "END-OF-TAPE" (send condition :report-string)) (search "EOM" (send condition :report-string))) ; DAB 06-09-89 (if (handle-eom-and-maybe-proceed ; DAB 04-03-89 Give them a change to continue. "The end of tape was encountered before completing the verify.~%Do you what to continue with another tape?" out-stream) (throw 'eom-restart :eom-error) ;Yes,continue ;;Otherwise show them the verification error in the last block. Then quit. (dolist (error-msg error-message-queue (setf error-message-queue ())) (format out-stream "~a" error-msg)) (throw 'eom-restart :complete)) ) (signal-condition condition))) ) ;;; DAB 04-03-89 We are queue all error message for a given block because when the end of ;;; Tape occurs the last block is duplicate on the next tape, but because of the read /write ;;; patterns we would get verification errors. We what these suppress if we continue with the next ;;; tape. (when (and error-message-queue (not (= l-hundred N-HUNDRED))) ; DAB 04-03-89 (dolist (error-msg error-message-queue (setf error-message-queue ())) (format out-stream "~a" error-msg))) (setf L-HUNDRED N-HUNDRED) (LET ((AMT (Si:rqb-n-Blocks TAPE-RQB))) (UNLESS (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T)) (si:%STRING-EQUAL DISK-BUF 0 TAPE-BUF 0 (* 1024 AMT))) (LET ((DISK-BUF-16-BIT (SYSTEM:RQB-BUFFER DISK-RQB)) (TAPE-BUF-16-BIT (SYSTEM:RQB-BUFFER TAPE-RQB))) (DO ((C 0 (1+ C)) (ERRS 0) (LIM (* 512 AMT))) ((OR (= C LIM) (= ERRS 3))) (COND ((NOT (= (AREF TAPE-BUF-16-BIT C) (AREF DISK-BUF-16-BIT C))) (push-end ; DAB 04-03-89 (FORMAT nil "~%Compare error on block ~D, halfword ~D, tape data(hex): ~16R disk data: ~16R " N-blocks-COMPARED (REM C 512) (AREF TAPE-BUF-16-BIT C) (AREF DISK-BUF-16-BIT C)) error-message-queue) (SETQ NO-ERRORS ()) (SETQ ERRS (1+ ERRS))))))) (SETQ N-blocks-COMPARED (+ N-blocks-COMPARED AMT))) (SETQ N-HUNDRED (MAYBE-DISPLAY-HUNDRED N-blocks-COMPARED N-HUNDRED OUT-STREAM)) ;;;;;;; IF THERE IS MORE TO READ RE-USE RQBS, ELSE QUEUE THEM FOR LATER CLEAN-UP (COND ((OR (= DISK-HIGH DISK-ADR) (= TO-HIGH TO-ADR)) (PUSH-END DISK-RQB IDLE-Q) (PUSH-END TAPE-RQB IDLE-Q)) (T (LET ((AMT (MIN (- DISK-HIGH DISK-ADR) (- TO-HIGH TO-ADR) BUF-SIZE))) (COND ((NOT (= AMT BUF-SIZE)) (SI::UNWIRE-DISK-RQB TAPE-RQB) (SI::UNWIRE-DISK-RQB DISK-RQB) (SI::WIRE-NUPI-RQB TAPE-RQB AMT T T) (SI::WIRE-NUPI-RQB DISK-RQB AMT T T) (SETQ DISK-BUF (SYSTEM:RQB-8-BIT-BUFFER DISK-RQB) TAPE-BUF (SYSTEM:RQB-8-BIT-BUFFER TAPE-RQB)))) (SI:nupi-read-wired tape-rqb tape-real-unit to-unit 0 T) (SETQ TO-ADR (+ TO-ADR AMT)) (PUSH-END (LIST TAPE-RQB TAPE-BUF) TAPE-Q) ;queues are list of '(rqb buffer) (SI:nupi-read-wired disk-rqb disk-real-unit disk-unit DISK-ADR T) (SETQ DISK-ADR (+ DISK-ADR AMT)) (PUSH-END (LIST DISK-RQB DISK-BUF) DISK-Q))))) (setf aborted-p nil) (when (setq cpu-type (send mt-closure :get :cpu-type)) ;Compare destination and source cpu, 3/19/87 mp (if (not (eq (nth-value 1 (si:parse-partition-name partition-namestring)) cpu-type)) (format out-stream "~& [Cpu-Types did not match.]"))) ) ;catch ) ) ;do exit forms NO-ERRORS) ;exit return ()) ;do ;;Unwind-protect forms (DEALLOCATE-Q DISK-Q OUT-STREAM) (DEALLOCATE-Q TAPE-Q OUT-STREAM) (DEALLOCATE-Q IDLE-Q OUT-STREAM) (SI::DISPOSE-OF-UNIT DISK-UNIT) (when (closurep mt-closure) (si:set-in-closure mt-closure 'mt:*abort-flag* aborted-p)) ;set *abort-flag* on abort 3/23/87 mp (SI::DISPOSE-OF-UNIT MT-CLOSURE) ;NO-ERRORS returns a meaningful value ) ;UNwind ))) ))