;;; -*- Mode:LISP; Package:LAMBDA; Lowercase:T -*- ;;; ;;; (c) Copyright 1984 - Lisp Machine, Inc. ;;; ;these two are set on the board with dip switches and jumpers (defconst tapemaster-system-configuration-pointer-address #x86) (defconst tapemaster-io-address #x60) (defconst tapemaster-system-configuration-block-address #x8000) (defconst tapemaster-channel-control-block-address #x9000) ; #x1f0 (defconst tapemaster-iopb-base-address 0) (defconst tapemaster-multibus-iopb-address #xa000) ; #x1fc0 (defconst tapemaster-block-buffer #xb000) ; should be safe for at least 10240. byte blocks (defconst tapemaster-memory-mode ':multibus) (defconst tapemaster-configure #x0) (defconst tapemaster-set-page #x8) (defconst tapemaster-nop #x20) (defconst tapemaster-drive-reset #x90) (defconst tapemaster-drive-status #x28) (defconst tapemaster-tape-assign #x74) (defconst tapemaster-overlapped-rewind #x04) (defconst tapemaster-read-forein-tape #x1c) (defconst tapemaster-rewind #x34) (defconst tapemaster-offline-and-unload #x38) (defconst tapemaster-write-filemark #x40) (defconst tapemaster-search-filemark #x44) (defconst tapemaster-serach-multiple #x94) (defconst tapemaster-space #x48) (defconst tapemaster-space-filemark #x70) (defconst tapemaster-erase #x4c) (defconst tapemaster-erase-whole-tape #x50) (defconst tapemaster-direct-read #x2c) (defconst tapemaster-direct-write #x30) (defconst tapemaster-direct-edit #x3c) (defconst tapemaster-buffered-read #x10) (defconst tapemaster-buffered-write #x14) (defconst tapemaster-buffered-edit #x18) (defconst tapemaster-streaming-read #x60) (defconst tapemaster-streaming-write #x64) (defconst tapemaster-block-move #x80) (defconst tapemaster-exchange #x0c) (defconst tapemaster-short-memory-test #x54) (defconst tapemaster-long-memory-test #x58) (defconst tapemaster-controller-confidence-test #x5c) (defconst tapemaster-test-read-write-timing #x68) (defun make-tapemaster-command-list (command-list) (cond ((null command-list) nil) (t (cons (cons (symeval (car command-list)) (string-capitalize-words (substring (string (car command-list)) 11.))) (make-tapemaster-command-list (cdr command-list)))))) (defconst tapemaster-command-list (make-tapemaster-command-list '(tapemaster-configure tapemaster-set-page tapemaster-nop tapemaster-drive-reset tapemaster-drive-status tapemaster-tape-assign tapemaster-overlapped-rewind tapemaster-read-forein-tape tapemaster-rewind tapemaster-offline-and-unload tapemaster-write-filemark tapemaster-search-filemark tapemaster-serach-multiple tapemaster-space tapemaster-space-filemark tapemaster-erase tapemaster-erase-whole-tape tapemaster-direct-read tapemaster-direct-write tapemaster-direct-edit tapemaster-buffered-read tapemaster-buffered-write tapemaster-buffered-edit tapemaster-streaming-read tapemaster-streaming-write tapemaster-block-move tapemaster-exchange tapemaster-short-memory-test tapemaster-long-memory-test tapemaster-controller-confidence-test tapemaster-test-read-write-timing))) (defun tapemaster-command-as-string (cmd) (let ((command-number-and-name (assoc cmd tapemaster-command-list))) (cond ((null command-number-and-name) (format nil "Unknown Tapemaster Command #x~16r" cmd)) (t (cdr command-number-and-name))))) (defconst tapemaster-error-list '((#x0 "Everything OK") (#x1 "timed out waiting for expected data busy false") (#x2 "timed out waiting for expected data busy false" "formatter busy and ready true") (#x3 "timed out waiting for expected ready false") (#x4 "timed out waiting for expected ready true") (#x5 "timed out waiting for expected data busy true") (#x6 "memory time out during system memory reference") (#x7 "blank tape was encountered unexpectedly") (#x8 "error in micro diagnostic") (#x9 "unexpeceted EOT or BOT encountered") (#xa "hard or soft error; retries didn't help") (#xb "read overflow or write underflow") ; unused #xc (#xd "read parity error on controller to transport interface") (#xe "internal prom checksum error") (#xf "tape time out" "if you are doing a read; probably the read count is larger than then record" "if you are doing a write; maybe the tape is bad") (#x10 "tape not ready") (#x11 "you tried to write, but the tape doesn't have a write ring") ; unused #x12 (#x13 "diagnostic command attempted; but the diagnostic jumper is not in") (#x14 "attempt to link from a command that doesn't allow linking") (#x15 "unexpected file mark during read operation") (#x16 "error in parameter block; usually 0 or too large byte count") ; unused #x17 (#x18 "UHE: unidentified hardware error") (#x19 "streaming read or write terminated by operating system or disk"))) (defun tapemaster-error-as-string (error-number &optional (brief-p t)) (let ((error-information (assoc error-number tapemaster-error-list))) (cond ((null error-information) (format nil "Unknown error number #x~16r" error-number)) ((null brief-p) (with-output-to-string (stream) (dolist (next-string (cdr error-information)) (format stream "~&~A" next-string)))) (t (cadr error-information))))) (defun tapemaster-build-iopb (command control buffer-size buffer-address) (let ((write-function-16 (selectq tapemaster-memory-mode (:nubus #'tapemaster-read-iopb-from-nubus-16) (:multibus #'tapemaster-read-iopb-from-multibus-16)))) (funcall write-function-16 0 command) (funcall write-function-16 2 0) ;high word of command (funcall write-function-16 4 control) (funcall write-function-16 6 0) ;return count (funcall write-function-16 10 buffer-size) (funcall write-function-16 12 0) ;records/overrun (funcall write-function-16 14 buffer-address) ;low 16 bits of buffer-address (funcall write-function-16 16 (dpb (ldb 2004 buffer-address) ;high 4 bits of buffer address 1404 0)) (funcall write-function-16 20 0) ;status (funcall write-function-16 22 0) ;first word of link field (funcall write-function-16 24 0) ;second word of link field ) (defun tapemaster-print-iopb () (let ((read-function-16 (selectq tapemaster-memory-mode (:nubus #'tapemaster-read-iopb-from-nubus-16) (:multibus #'tapemaster-read-iopb-from-multibus-16)))) (format t "~&command: ~A" (tapemaster-command-as-string (funcall read-function-16 0))) (cond ((not (zerop (funcall read-function-16 2))) (format t "~&warning: second word of command not zero"))) (let ((control (funcall read-function-16 4))) (format t "~&tape select: ~D" (ldb 0202 control)) (format t "~&mailbox interrupt: ~O" (ldb 0401 control)) (format t "~&interrupts: ~O" (ldb 0501 control)) (format t "~&link bit: ~O" (ldb 0601 control)) (format t "~&bus lock: ~O" (ldb 0701 control)) (format t "~&bank select: ~O" (ldb 1001 control)) (format t "~&reverse: ~O" (ldb 1201 control)) (format t "~&speed: ~O" (ldb 1301 control)) (format t "~&continous: ~O" (ldb 1401 control)) (format t "~&bus width: ~D." (if (ldb-test 1701 control) 16. 8.))) (let ((return-count (funcall read-function-16 6))) (format t "~&return count: ~O (~D.)" return-count return-count)) (let ((buffer-size (funcall read-function-16 10))) (format t "~&buffer size: ~O (~D.)" buffer-size buffer-size)) (let ((records-or-overrun (funcall read-function-16 12))) (format t "~&records/overrun ~O (~D.)" records-or-overrun records-or-overrun)) (format t "~&buffer address: ~O" (+ (funcall read-function-16 14) (dpb (funcall read-function-16 16) 0420 0))) (let ((status (funcall read-function-16 20))) (format t "~&write ring is ~A" (if (ldb-test 0101 status) "in" "out")) (format t "~&formatter is ~A" (if (ldb-test 0201 status) "busy" "idle")) (format t "~&selected drive is ~A" (if (ldb-test 0301 status) "ready" "not ready")) (if (ldb-test 0401 status) (format t "~&at end of tape")) (if (ldb-test 0501 status) (format t "~&at beginning of tape")) (if (ldb-test 0601 status) (format t "~&selected drive is on line") (format t "~&selected drive is off line")) (if (ldb-test 0701 status) (format t "~&a file mark was detected on this operation")) (let ((error-number (ldb 1005 status))) (cond ((not (zerop error-number)) (format t "error: ~A" (tapemaster-error-as-string error-number))))) (if (ldb-test 1501 status) (format t "~&this command had to be retried")) (if (ldb-test 1601 status) (format t "~&command complete")) (if (ldb-test 1701 status) (format t "~&command received by controller"))) (if (or (not (zerop (funcall read-function-16 22))) (not (zerop (funcall read-function-16 24)))) (format t "~&warning: interrupt//link field is not zero")))) (defun tapemaster-read-iopb-from-nubus-16 (address-within-iopb) (let ((wd (nd-slot-read mem-slot (lsh (+ tapemaster-iopb-base-address address-within-iopb) -2)))) (ldb (byte 16. (* (ldb 0101 wd) 16.))))) (defun tapemaster-write-iopb-to-nubus-16 (address-within-iopb data) (let ((wd (nd-slot-read mem-slot (lsh (+ tapemaster-iopb-base-address address-within-iopb) -2)))) (setq wd (dpb data (byte 16. (* (ldb 0101 address-within-iopb) 16.)) wd)) (nd-slot-write mem-slot (lsh (+ tapemaster-iopb-base-address address-within-iopb) -2) wd))) (defun tapemaster-read-iopb-from-multibus-16 (address-within-iopb) (multibus-read-16 (+ tapemaster-multibus-iopb-address address-within-iopb))) (defun tapemaster-write-iopb-to-multibus-16 (address-within-iopb data) (multibus-write-16 (+ tapemaster-multibus-iopb-address address-within-iopb) data)) (defun tapemaster-initialize () ;set up system configuration-pointer (multibus-io-write-16 (+ tapemaster-io-address 1) 0) ;reset (multibus-byte-write tapemaster-system-configuration-pointer-address 1) ;a 16 bit bus (multibus-byte-write (+ tapemaster-system-configuration-pointer-address 1) 0) ;unused byte (multibus-byte-write (+ tapemaster-system-configuration-pointer-address 2) (ldb 0010 tapemaster-system-configuration-block-address));low 8 bits (multibus-byte-write (+ tapemaster-system-configuration-pointer-address 3) (ldb 1010 tapemaster-system-configuration-block-address));next 8 bits (multibus-byte-write (+ tapemaster-system-configuration-pointer-address 4) 0) (multibus-byte-write (+ tapemaster-system-configuration-pointer-address 5) (dpb (ldb 2004 tapemaster-system-configuration-block-address);high 4 0404 ;shifted 0)) ;set up system configuration block (multibus-write-16 tapemaster-system-configuration-block-address 3) (multibus-write-16 (+ tapemaster-system-configuration-block-address 2) tapemaster-channel-control-block-address) (multibus-write-16 (+ tapemaster-system-configuration-block-address 4) (dpb (ldb 2004 tapemaster-channel-control-block-address) 1404 0)) ;set up channel control block (multibus-write-16 tapemaster-channel-control-block-address #xff11) ; ccw and gate (multibus-io-write-16 tapemaster-io-address 0) ;send channel attention (error-restart (gate-time-out "keep waiting for tape command to finish") (with-timeout ((* 60. 5.) (ferror 'gate-time-out "tapemaster command failed to finish after 5 seconds")) (do () ((zerop (multibus-byte-read (+ tapemaster-channel-control-block-address 1))))))) t) (defun tapemaster-execute-command (command control buffer-size buffer-address) (error-restart (gate-time-out "keep waiting for gate to open") (with-timeout ((* 60. 3) (ferror 'gate-time-out "tapemaster gate failed to open after 3 seconds")) (do () ((zerop (multibus-byte-read (+ tapemaster-channel-control-block-address 1))))))) (multibus-byte-write (+ tapemaster-channel-control-block-address 1) #xff) (selectq tapemaster-memory-mode (:nubus (ferror nil "not implemented yet")) (:multibus (tapemaster-build-iopb command control buffer-size buffer-address #'tapemaster-write-iopb-to-multibus-16) (multibus-write-16 (+ tapemaster-channel-control-block-address 2) tapemaster-multibus-iopb-address))) (multibus-io-write-16 tapemaster-io-address 0) ;send channel attention (error-restart (gate-time-out "keep waiting for tape command to finish") (let ((reasonable-time (cond ((eq command tapemaster-rewind) 120.) (t 5.)))) (with-timeout ((* 60. reasonable-time) (ferror 'gate-time-out "tapemaster command failed to finish after ~D. seconds" reasonable-time)) (do () ((zerop (multibus-byte-read (+ tapemaster-channel-control-block-address 1)))))))) t) ;only copied from fs:band-magtape-handler - doesn't have a hope of working (defselect (lam-band-magtape-handler ignore) ; (:read (rqb block) ; block ; (funcall *band-stream* ':string-in "unexpected EOF" ; (rqb-buffer rqb) 0 (* (rqb-npages rqb) 1000))) (:write (rqb block &aux (n-blocks (rqb-npages rqb)) (n-hwds (* n-blocks 1000)) (buf (rqb-buffer rqb))) block (or *lam-band-stream* (setq *lam-band-stream* (lam-make-mt-file-stream ':direction ':output ':plist *lam-band-plist* ':characters nil))) (funcall *lam-band-stream* ':string-out buf 0 n-hwds)) (:dispose () (cond (*lam-band-stream* (funcall *lam-band-stream* ':close) (setq *lam-band-stream* nil)))) (:handles-label () t) (:get (ind) (get (locf *lam-band-plist*) ind)) (:put (prop ind) (putprop (locf *lam-band-plist*) prop ind)) (:find-disk-partition (name &aux tem) (if (setq tem (get-from-alternating-list *lam-band-plist* ':name)) (if (not (equal name tem)) (if (null (y-or-n-p (format nil "~%Tape partition ~s, OK?" *lam-band-plist*))) (break foo t))) (putprop (locf *lam-band-plist*) name ':name)) (values 0 (or (get (locf *lam-band-plist*) ':size) 3777777) nil)) (:partition-comment (ignore) (get (locf *lam-band-plist*) ':comment))) (defun lam-tape-write-block (art-8b-array length-in-bytes) (dotimes (i length-in-bytes) (multibus-byte-write (+ tapemaster-block-buffer i) (aref art-8b-array i))) (tapemaster-build-iopb tapemaster-direct-write 0 length-in-bytes tapemaster-block-buffer