source: trunk/lisp/lmcons/dcheck.lisp @ 217

Last change on this file since 217 was 217, checked in by rjs, 3 years ago

Version 80.

File size: 41.0 KB
Line 
1;;; -*- Mode:Lisp; Package:CADR; Base:8; Lowercase:yes -*-
2
3;;; DCHECK - for checking out newly-constructed disk controls
4;;; Goes in CADR package
5
6(DECLARE (COND ((STATUS FEATURE LISPM))   ;DO NOTHING ON LISP MACHINE.
7               ((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
8                (BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
9               ((NULL (GET 'IF-FOR-MACLISP 'MACRO))
10                (LOAD '(MACROS > DSK LISPM2))  ;Just #M and #Q really
11                (MACROS T)))) ;SEND OVER THE REST OF THE MACROS IN THIS FILE
12
13(DECLARE (SPECIAL BYPASS-SEEKS))
14(SETQ BYPASS-SEEKS NIL) ;NON-NIL INHIBITS SEEKING IN DCHECK
15
16(DEFVAR MARKSMAN-P NIL) ;You must set this to T if you are testing a marksman
17
18(declare (special local-disk-p))  ;Local disk at normal address -4
19(setq local-disk-p nil)
20
21(DECLARE (SPECIAL SPY-ACCESS-PATH CC-SUSPECT-BIT-LIST CC-DIAG-TRACE
22                  DCHECK-AND DCHECK-IOR DCHECK-ADR-AND DCHECK-ADR-IOR
23                  DC-STS-ADR DC-MA-ADR DC-DA-ADR DC-ECC-ADR DC-CMD-ADR DC-CLP-ADR DC-START-ADR
24                  DC-READ DC-WRITE DC-SEEK DC-RECAL DC-FAULT-CLEAR DC-READ-ALL DC-WRITE-ALL
25                  DC-READ-COMPARE DC-AT-EASE DC-OFFSET-CLEAR DC-STOP
26                  DC-SOME-ERROR-BITS DC-ALL-ERROR-BITS CCW-LOC NXM-LOC1 NXM-LOC2 NXM-LOC3))
27
28(SETQ DC-STS-ADR 17377774
29      DC-MA-ADR 17377775
30      DC-DA-ADR 17377776
31      DC-ECC-ADR 17377777
32      DC-CMD-ADR 17377774
33      DC-CLP-ADR 17377775
34      DC-START-ADR 17377777)
35
36(SETQ DC-READ 0 DC-READ-COMPARE 10 DC-WRITE 11 DC-READ-ALL 2 DC-WRITE-ALL 13
37      DC-SEEK 4 DC-AT-EASE 5 DC-RECAL 10001005 DC-FAULT-CLEAR 10000405 DC-OFFSET-CLEAR 6
38      DC-STOP 16)
39
40(SETQ DC-SOME-ERROR-BITS 06077560  ;MUL-SEL, NO-SEL, FLT, OFF-CYL, OFF-LINE, SEEK-ERR, TIMEOUT,
41                                   ;START-BLOCK, TRANSFER-ABORTED, OVERRUN, PAR, NXM
42      DC-ALL-ERROR-BITS ;47777560   ;ALSO ECC-SOFT, ECC-HARD, ECC-HDR, HCE, IPE
43                        (+ (LSH 1 23.) 7777560) ;AVOID MAKING BIGNUM
44      CCW-LOC 777
45      NXM-LOC1 16777777          ;THESE 3 ATTEMPT TO GET 1 AND 0 IN ALL BITS
46      NXM-LOC2 15000000          ;ASSUMING MACHINE HAS LESS THAN 1792K CORE
47      NXM-LOC3 07000000)
48
49(PROGN 'COMPILE  ;Damned splicing macros don't work at top level
50#M (PROGN 'COMPILE
51(DECLARE (FIXNUM (PHYS-MEM-READ FIXNUM) (DC-READ-MA))
52         (NOTYPE (PHYS-MEM-WRITE FIXNUM FIXNUM)
53                 (DCHECK-COMPARE FIXNUM FIXNUM) (DCHECK-PM NOTYPE FIXNUM)))
54
55(DECLARE (*EXPR PHYS-MEM-READ PHYS-MEM-WRITE
56                CC-FINGER-SUSPECT-BIT CC-PRINT-SET-BITS CC-PRINT-BIT-LIST))
57
58(DECLARE (FIXNUM I J K M N BITNO MASK ADR VAL))
59
60(DEFUN LOGAND MACRO (X) `(BOOLE 1 . ,(CDR X)))
61
62(DEFUN LOGIOR MACRO (X) `(BOOLE 7 . ,(CDR X)))
63
64(DEFUN LOGXOR MACRO (X) `(BOOLE 6 . ,(CDR X)))
65
66(DEFUN LDB-TEST MACRO (X)
67  (LET ((PP (LSH (CADR X) -6))
68        (SS (LOGAND 77 (CADR X)))
69        (W (CADDR X)))
70    (LIST 'NOT (LIST 'ZEROP (LIST 'LOGAND (LSH (1- (LSH 1 SS)) PP) W)))))
71
72(DEFUN PHYS-MEM-READ-24 MACRO (X)
73  (RPLACA X 'PHYS-MEM-READ))
74
75);#M
76
77#Q
78(DEFUN PHYS-MEM-READ-24 MACRO (X)
79  `(LET ((VAL (PHYS-MEM-READ . , (CDR X))))
80     (LOGIOR (LSH (LDB 2701 VAL) 27) (LDB 27 VAL)))) ;Ensure fixnum
81);PROGN 'COMPILE
82
83(defun use-local-disk ()
84  (setq local-disk-p t
85        DC-STS-ADR 377770
86        DC-MA-ADR 377771
87        DC-DA-ADR 377772
88        DC-ECC-ADR 377773
89        DC-CMD-ADR 377770
90        DC-CLP-ADR 377771
91        DC-START-ADR 377773)
92  (fset'phys-mem-read 'xbus-read)
93  (fset'phys-mem-write 'xbus-write))
94
95(defun xbus-read (loc)
96  (setq loc (+ loc (lsh 77 18.)))
97  (dpb (%p-ldb 2020 loc) 2020 (%p-ldb 0020 loc)))
98
99(defun xbus-write (loc val)
100  (%p-store-tag-and-pointer (+ loc (lsh 77 18.))
101                            (ldb 3010 val)
102                            (%24-bit-plus (lsh (ldb 2701 val) 27)
103                                          (ldb 0027 val))))
104
105
106;;; Basic disk manipulation
107
108(DEFUN DC-READ-MA ()  ;High bits of this register are garbage, only 22 bits are really MA
109  (LOGLDB 0026 (PHYS-MEM-READ DC-MA-ADR)))
110
111(DEFUN DC-PRINT-STATUS ()
112  (DC-PRINT-STATUS1 (PHYS-MEM-READ DC-STS-ADR)))
113
114(DEFUN DC-PRINT-STATUS1 (STATUS)
115     (TERPRI)
116     (CC-PRINT-SET-BITS STATUS '( IDLE ANY-ATTN SEL-UNIT-ATTN INTR MULTIPLE-SELECT NO-SELECT
117                                  SEL-UNIT-FAULT SEL-UNIT-READ-ONLY SEL-UNIT-OFF-CYLINDER
118                                  SEL-UNIT-OFF-LINE SEL-UNIT-SEEK-ERROR TIMEOUT-ERROR
119                                  START-BLOCK-ERROR TRANSFER-ABORTED OVERRUN
120                                  ECC-SOFT ECC-HARD ECC-HEADER HEADER-COMPARE-ERROR
121                                  MEM-PARITY-ERROR NXM-ERROR CCW-CYCLE READ-COMPARE-DIFFERENCE
122                                  INTERNAL-PARITY-ERROR ))
123     #M (PROGN (PRINC '| SEL-UNIT-BLOCK-CTR=|) (PRIN1 (LSH STATUS -24.))))
124
125(defun dc-print-marksman-status ()
126  (let ((sts))
127    (dc-print-status)
128    (terpri)
129    (let ((da (phys-mem-read dc-da-adr)))
130      (format t "~%Disk address: cylinder ~o, head ~o, block ~o (octal)~%"
131                (ldb 2020 da) (ldb 1010 da) (ldb 0010 da)))
132    (princ "Current status: ")
133    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
134    (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready
135                              spin-out-of-limit end-of-cyl diag-error track-zero-error ))
136    (princ ", Re-read status: ")
137    (dc-exec-1 5)
138    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
139    (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready
140                              spin-out-of-limit end-of-cyl diag-error track-zero-error ))
141
142    (dc-exec-1 200005)
143    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
144    (princ '|sector-length=|)
145    (prin1 (logldb 0002 sts))
146    (tyo 40)
147    (cc-print-set-bits sts '( nil nil illegal-set-sector sector-switches-overridden
148                              illegal-rezero-or-illegal-seek illegal-cylinder illegal-command
149                              write-protect-violation ))
150    (terpri)
151    (dc-exec-1 400005)
152    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
153    (princ '|last cmd byte 1=|)
154    (prin1 sts)
155    (dc-exec-1 600005)
156    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
157    (princ '|, byte 2=|)
158    (prin1 sts)
159    (dc-exec-1 1000005)
160    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
161    (princ '|, cur cyl=|)
162    (prin1 sts)
163    (dc-exec-1 1200005)
164    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
165    (princ '|, sec//trk-1=|)
166    (prin1 sts)
167    (dc-exec-1 1400005)
168    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
169    (princ '|, diag sts 1=|)
170    (prin1 sts)
171    (dc-exec-1 1600005)
172    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
173    (princ '|, diag sts 2=|)
174    (prin1 sts)))
175
176;;; Seek, print status if error
177(DEFUN DC-SEEK (CYL)
178  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
179  (PHYS-MEM-WRITE DC-START-ADR 0)
180  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
181  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 0))
182  (PHYS-MEM-WRITE DC-CMD-ADR (logdpb cyl 3010 (logdpb 100 2010 DC-SEEK)))
183  (PHYS-MEM-WRITE DC-START-ADR 0)
184  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
185  (OR MARKSMAN-P
186      (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention
187        #M (SLEEP 0.03)
188        #Q (PROCESS-ALLOW-SCHEDULE)
189        ))
190  (DC-CHECK-STATUS DC-SOME-ERROR-BITS))
191
192(defun dc-recal-marksman ()
193  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
194  (dc-exec 10000005 0 0 0 0 nil 0)
195  (dc-print-marksman-status))
196
197;;; Run internal marksman diagnostics (this doesn't work, maybe we don't have the firmware)
198(defun dc-diag-marksman (test-number)
199  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
200  (PHYS-MEM-WRITE DC-CMD-ADR (logdpb (+ 200 test-number) 2010 5))
201  (PHYS-MEM-WRITE DC-START-ADR 0)
202  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
203  (dc-print-marksman-status))
204
205;;; Perform a read or write, check specified status bits.
206(DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS)
207  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
208  (PHYS-MEM-WRITE DC-START-ADR 0)
209  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
210  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK)))
211  (PHYS-MEM-WRITE DC-CLP-ADR CLP)
212  (AND CCW (PHYS-MEM-WRITE CLP CCW))
213  (PHYS-MEM-WRITE DC-CMD-ADR CMD)
214  (PHYS-MEM-WRITE DC-START-ADR 0)
215  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR))) ;Await Idle
216    #M (SLEEP 0.03)
217    #Q (KBD-CHAR-AVAILABLE)
218    )
219  (DC-CHECK-STATUS ERR-BITS))
220
221;;; Very simplified version used for reading back status.  Don't want to bash
222;;; disk address register.
223(DEFUN DC-EXEC-1 (CMD)
224  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
225  (PHYS-MEM-WRITE DC-CMD-ADR CMD)
226  (PHYS-MEM-WRITE DC-START-ADR 0)
227  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR))) ;Await Idle
228    #M (SLEEP 0.03)
229    #Q (KBD-CHAR-AVAILABLE)
230    ))
231
232;;; Barf if any of specified bits on in status
233(DEFUN DC-CHECK-STATUS (MASK)
234  (LET ((VAL (PHYS-MEM-READ-24 DC-STS-ADR)))
235    (COND ((NOT (ZEROP (LOGAND MASK VAL)))
236           (DC-PRINT-STATUS1 VAL)))))
237
238;;; This function provides a scope loop for debugging problems starting up
239;;; the microcode that would otherwise lead to hangs.
240(DEFUN DC-RAPID-START ()
241  (DO () ((KBD-TYI-NO-HANG))
242    (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)      ;Do the command that loses (at ease
243    (PHYS-MEM-WRITE DC-START-ADR 0)             ; is the most null command)
244    (DOTIMES (I 100) NIL)
245    (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP)         ;Stop the disk control forcibly
246    (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)))    ;Cease to stop
247
248;;; Simpler version of DC-EXEC, for scoping
249(DEFUN DC-EXEC-2 (CMD CYL HEAD BLOCK CLP CCW ERR-BITS)
250  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK)))
251  (PHYS-MEM-WRITE DC-CLP-ADR CLP)
252  (AND CCW (PHYS-MEM-WRITE CLP CCW))
253  (PHYS-MEM-WRITE DC-CMD-ADR CMD)
254  (PHYS-MEM-WRITE DC-START-ADR 0)
255  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR))) ;Await Idle
256    #M (SLEEP 0.03)
257    #Q (KBD-CHAR-AVAILABLE)
258    )
259  (DC-CHECK-STATUS ERR-BITS))
260
261;;; Test function
262
263(DEFUN DCHECK (&AUX CONTROLLER-TYPE)
264  (SETQ CONTROLLER-TYPE (LDB (BITS 2 22.) (PHYS-MEM-READ DC-MA-ADR)))
265  (FORMAT T
266      "~&CONTROLLER TYPE IS ~D~0G (~[Trident~;Marksman~;unused?~;Unmodified Trident~])~%"
267      CONTROLLER-TYPE)
268  ;Don't do this, the hardware isn't necessarily right.  This IS a diagnostic, after all.
269  ;(SETQ MARKSMAN-P (= CONTROLLER-TYPE 1))
270  (FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P)
271  ;; Part 1 - verify bus response to reading and writing disk-address register
272  (PHYS-MEM-WRITE DC-DA-ADR 1777777777) ;28 bits
273  (COND ((ZEROP (PHYS-MEM-READ DC-DA-ADR))
274         (DCHECK-ERR-LOOP '|No response on Unibus or Xbus, or failed to write or read DA|
275                          DC-DA-ADR 1777777777 1777777777)))
276  ;; Part 2 - write 0 in DA, check for bits stuck at 1
277  (PHYS-MEM-WRITE DC-DA-ADR 0)
278  (DO ((VAL (PHYS-MEM-READ DC-DA-ADR))
279       (BITNO 0 (1+ BITNO))
280       #M (MASK 1 (LSH MASK 1))
281       (CC-SUSPECT-BIT-LIST NIL))
282      ((= BITNO 28.)
283       (COND ((NOT (NULL CC-SUSPECT-BIT-LIST))
284              (CC-PRINT-BIT-LIST '|Bits in DA register stuck at 1, may be/
285  broken wire in XBI or XBO data paths: |
286                                 CC-SUSPECT-BIT-LIST)
287              (DCHECK-ERR-LOOP '|Some bits in DA register won't clear|
288                               DC-DA-ADR 0 0))))
289    (AND #M (NOT (ZEROP (LOGAND MASK VAL)))
290         #Q (LDB-TEST (1+ (LSH BITNO 6)) VAL)
291         (CC-FINGER-SUSPECT-BIT BITNO)))
292  ;; Part 3 - write floating 1's in DA, check for bits stuck at 0 or spuriously 1
293  (DO ((BITNO 0 (1+ BITNO))
294       (MASK 1 (+ MASK MASK)) ;May be bignum on Lisp machine
295       #Q (PPSS 0001 (+ PPSS 100))
296       (VAL)
297       (CC-SUSPECT-BIT-LIST NIL)
298       (STUCK-0 NIL)
299       (SPURIOUS-1 NIL))
300      ((= BITNO 28.)
301       (CC-PRINT-BIT-LIST '|Bits in DA register stuck at 0: | STUCK-0)
302       (CC-PRINT-BIT-LIST '|Bits in DA register 1 when they shouldn't be: | SPURIOUS-1)
303       (AND STUCK-0
304            (DCHECK-ERR-LOOP '|Testing first stuck-0 bit in DA register:|
305                             DC-DA-ADR 0 (LOGDPB 1 (1+ (LSH (CAR STUCK-0) 6)) 0)))
306       (AND SPURIOUS-1
307            (DCHECK-ERR-LOOP '|Testing first spurious-1 bit in DA register:|
308                            DC-DA-ADR 0 (LOGDPB 0 (1+ (LSH (CAR SPURIOUS-1) 6)) 1777777777))))
309    (PHYS-MEM-WRITE DC-DA-ADR MASK)
310    (SETQ VAL (PHYS-MEM-READ DC-DA-ADR))
311    (AND #M (ZEROP (LOGAND MASK VAL))
312         #Q (NOT (LDB-TEST PPSS VAL))
313         (SETQ STUCK-0 (CONS BITNO STUCK-0)))
314    (DO I 0 (1+ I) (= I 28.)
315      (AND (NOT (= I BITNO))
316           #M (NOT (ZEROP (LOGAND (LSH 1 I) VAL)))
317           #Q (LDB-TEST (1+ (LSH I 6)) VAL)
318           (SETQ SPURIOUS-1 (CONS I SPURIOUS-1)))))
319  ;; Part 3.5 - check that the block counter is counting.  This checks
320  ;; that the disk is rotating and that the index/sector pulse logic works.
321  #Q (DCHECK-BLOCK-COUNTER)
322  ;; Part 3.6 - recalibrate.  Marksman needs this if I/O reset has been done.
323  (FORMAT T "~&Recalibrate...")
324  (DC-RECALIBRATE)
325  ;; Part 4 - Test disk bus bits and basic command logic by seeking
326  (COND ((NOT BYPASS-SEEKS)
327         (DCHECK-SEEK (if marksman-p 209. 814.))
328         (DO I (if marksman-p 128. 512.) (LSH I -1) (ZEROP I)
329           (DCHECK-SEEK I))))
330  (and local-disk-p (break the-rest-of-this-aint-gonna-work))
331  ;; Part 5 - Check address logic by reading with a CLP that points at NXM
332  ;;          and then a CCW that points at NXM, check error status and MA.
333  ;;   Note that if the read fails to happen, e.g. due to header-compare-error, the
334  ;;   MA is naturally going to be wrong also since no memory cycles at all will happen.
335  (LET ((MASK   ;Bits which are suspect (this stuff is only 22 bits, fits in fixnum)
336         (LOGIOR (DCHECK-CLP-ADR NXM-LOC1) (DCHECK-CLP-ADR NXM-LOC2) (DCHECK-CLP-ADR NXM-LOC3)
337                 (DCHECK-CCW-ADR NXM-LOC3) (DCHECK-CCW-ADR NXM-LOC2) (DCHECK-CCW-ADR NXM-LOC1)
338                 )))
339    (COND ((NOT (ZEROP MASK))
340           (DCHECK-ERR-LOOP   ;Not the ultimate winning test loop, but maybe OK for now
341              '|Writing CLP, reading MA (should be 16777777), frobbing bits that failed|
342              DC-CLP-ADR 0 MASK))))
343  ;; Part 6 - Write and read block 1 of the disk.  Use a floating 1's and 0's
344  ;;          pattern, and then an address pattern, and check for Xbus data path
345  ;;          and addressing failures.
346  ;; This doesn't check high-order address bits
347  (DO I 0 (1+ I) (= I 40)       ;Loc 0-37 get floating 1's
348    (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I)))
349  (DO I 0 (1+ I) (= I 40)       ;Loc 40-77 get floating 0's
350    (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
351  (DO I 100 (1+ I) (= I 400)    ;Loc 100-377 get address pattern
352    (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
353  (PRINT 'WRITE)
354  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
355  (LET ((MA (DC-READ-MA)))
356    #M (DECLARE (FIXNUM MA))
357    (COND ((NOT (= MA 377))
358           (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|)
359           (PRIN1 MA))))
360  (DO I 0 (1+ I) (= I 400)      ;Clear buffer
361    (PHYS-MEM-WRITE I 0))
362  (PRINT 'READ)
363  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
364  (LET ((MA (DC-READ-MA)))
365    #M (DECLARE (FIXNUM MA))
366    (COND ((NOT (= MA 377))
367           (TERPRI) (PRINC '|MA wrong on read of pattern, correct=377, actual=|)
368           (PRIN1 MA))))
369  ;; Check pattern read back into core, see if it's correct
370  (LET ((DCHECK-AND 37777777777) (DCHECK-IOR 0)  ;Accumulate error bits here
371        (DCHECK-ADR-AND 377) (DCHECK-ADR-IOR 0))
372    (DO I 0 (1+ I) (= I 40)     ;Loc 0-37 get floating 1's
373      (DCHECK-COMPARE I (#M LSH #Q ASH 1 I)))
374    (DO I 0 (1+ I) (= I 40)     ;Loc 40-77 get floating 0's
375      (DCHECK-COMPARE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
376    (DO I 100 (1+ I) (= I 400)  ;Loc 100-377 get address pattern
377      (DCHECK-COMPARE I (+ (#M LSH #Q ASH (LOGXOR 377 I) 8) I)))
378    (DCHECK-PM '|Data bits dropped during write to or read from disk: |
379               (LOGXOR 37777777777 DCHECK-IOR))
380    (DCHECK-PM '|Data bits picked during write to or read from disk: |
381               DCHECK-AND)
382    (DCHECK-PM '|Address bits 0 with bad data during write to or read from disk: |
383               (LOGXOR 377 DCHECK-ADR-AND))
384    (DCHECK-PM '|Address bits 1 with bad data during write to or read from disk: |
385               DCHECK-ADR-IOR))
386  ;; Maybe there should be a test-loop for the above?
387  ;; part 7 - in case loser didn't look at the heads and see that they moved
388  ;; correctly during part 4, which is hard to do on a T-300, we will here
389  ;; assume we have a good pack and try reading from each power of 2 cylinder.
390  ;; This will get a header-compare error if a disk bus bit doesn't work.
391  (TERPRI)
392  (PRINC "Trying reads of various blocks; will get HEADER-COMPARE if disk bus bits bad")
393  (TERPRI)
394  (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS)
395  (PRINC " cyl 0 ")
396  (DO CYL 1 (LSH CYL 1) (= CYL 2000)
397    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS)
398    (PRINC " cyl ")
399    (PRIN1 CYL))
400  ;; end
401  (TERPRI)
402  (PRINC "You might enjoy trying DC-WRITE-READ-TEST")
403  (TERPRI)
404  (PRINC '|End of DCHECK.  Now run the format program and the ECC test program.|))
405
406(DEFUN DC-RESET NIL
407  (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP)
408  (PHYS-MEM-WRITE DC-CMD-ADR 0))
409
410(DEFUN DC-RECALIBRATE NIL
411  (DC-EXEC DC-RECAL 0 0 0 0 NIL 0)
412  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
413    (PROCESS-ALLOW-SCHEDULE)))
414
415(DEFUN DC-FAULT-CLEAR NIL
416  (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0)
417  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
418    (PROCESS-ALLOW-SCHEDULE)))
419
420;;; Compare pattern, set special variables if lose
421;;; Also obeys CC-DIAG-TRACE
422(DEFUN DCHECK-COMPARE (ADR VAL)
423  (LET ((MASK (PHYS-MEM-READ ADR)))
424    (SETQ DCHECK-AND (LOGAND DCHECK-AND MASK)
425          DCHECK-IOR (LOGIOR DCHECK-IOR MASK))
426    (COND ((NOT (= MASK VAL))
427           (AND CC-DIAG-TRACE
428                (FORMAT T "~&Address ~O Good ~O Bad ~O~%" ADR VAL MASK))
429           (SETQ DCHECK-ADR-AND (LOGAND DCHECK-ADR-AND ADR)
430                 DCHECK-ADR-IOR (LOGIOR DCHECK-ADR-IOR ADR))))
431    NIL))
432
433;;; Print bit list given as mask
434(DEFUN DCHECK-PM (MESSAGE MASK &AUX CC-SUSPECT-BIT-LIST) ;CC-PRINT-BIT-LIST looks at it
435  (OR (ZEROP MASK)
436      (CC-PRINT-BIT-LIST MESSAGE
437                         (DO ((BITNO 0 (1+ BITNO))
438                              (L NIL))
439                             ((ZEROP MASK) L)
440                           (AND (ODDP MASK) (SETQ L (CONS BITNO L)))
441                           (SETQ MASK (#M LSH #Q ASH MASK -1))))))
442
443;;; Check that the block counter is counting, and producing
444;;; all the right values and only the right values.  This one
445;;; will not run in Maclisp.
446#Q
447(DEFUN DCHECK-BLOCK-COUNTER ()
448  (DO ((DESIRED-VALUES #10R (IF MARKSMAN-P
449                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
450                                ;; Vandals: Yes, a value of 17. can appear here
451                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)))
452       (GOOD-VALUES NIL)
453       (BAD-VALUES NIL)
454       (MISSING-VALUES)
455       (BCTR)
456       (START-TIME (TIME)))
457      ((> (TIME-DIFFERENCE (TIME) START-TIME) 30.)      ;Run for 1/2 second
458       (SETQ GOOD-VALUES (SORT GOOD-VALUES #'<))
459       (SETQ BAD-VALUES (SORT BAD-VALUES #'<))
460       (SETQ MISSING-VALUES (COPYLIST DESIRED-VALUES))
461       (DOLIST (X GOOD-VALUES)
462         (SETQ MISSING-VALUES (DELQ X MISSING-VALUES)))
463       (AND (OR BAD-VALUES MISSING-VALUES)
464            (FORMAT T "~&Problems with block counter.  May be disk not spinning, lack of
465 index or sector pulse, or problem with block counter logic.~%"))
466       (AND BAD-VALUES (FORMAT T "Erroneous values seen (octal): ~{~O~^,~}~%" BAD-VALUES))
467       (AND MISSING-VALUES (FORMAT T "Values not seen (octal): ~{~O~^,~}
468Good values that were seen: ~{~O~^,~}~%" MISSING-VALUES GOOD-VALUES)))
469    (SETQ BCTR (LDB 3010 (PHYS-MEM-READ DC-STS-ADR)))
470    (IF (MEMQ BCTR DESIRED-VALUES)
471        (OR (MEMQ BCTR GOOD-VALUES) (PUSH BCTR GOOD-VALUES))
472        (OR (MEMQ BCTR BAD-VALUES) (PUSH BCTR BAD-VALUES)))))
473
474;;; Check address logic, return bits which failed
475(DEFUN DCHECK-CLP-ADR (ADR)
476  (LET ((MA 0))
477    (DECLARE (FIXNUM MA))
478    (DC-EXEC DC-READ 0 0 0 ADR NIL 0)
479    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
480                   14000000))  ;NXM and CCW CYCLE
481           (DC-PRINT-STATUS) (TERPRI)
482           (PRINC '|NXM or CCW-CYCLE failure with CLP pointing to non-existent memory loc |)
483           (PRIN1 ADR)))
484    (SETQ MA (DC-READ-MA))
485    (COND ((NOT (= MA ADR))
486           (TERPRI)
487           (PRINC '|MA wrong on CLP nxm, probably address data path failure, correct=|)
488           (PRIN1 ADR)
489           (PRINC '|, actual=|)
490           (PRIN1 MA)
491           (LOGXOR MA ADR))
492          (T 0))))
493
494;Tight reading loop.
495(DEFUN DCHECK-HEADER-COMPARE-LOOP NIL
496 (DO () ((KBD-TYI-NO-HANG))
497   (DC-EXEC DC-READ 0 0 0 CCW-LOC 1000 0)))
498
499(DEFUN DCHECK-CCW-ADR (ADR)
500  (LET ((MA 0))
501    (DECLARE (FIXNUM MA))
502    (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0)
503    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
504                   04000000))  ;NXM and -CCW CYCLE
505           (DC-PRINT-STATUS) (TERPRI)
506           (PRINC '|NXM or CCW-CYCLE failure with CCW pointing to non-existent memory loc |)
507           (PRIN1 ADR)))
508    (SETQ MA (DC-READ-MA))
509    (COND ((NOT (= MA ADR))
510           (TERPRI)
511           (PRINC '|MA wrong on CCW nxm, probably address data path failure, correct=|)
512           (PRIN1 ADR)
513           (PRINC '|, actual=|)
514           (PRIN1 MA)
515           (LOGXOR MA ADR))
516          (T 0))))
517
518;;; Alternating seek test
519(DEFUN DCHECK-SEEK (CYL)
520  (TERPRI)
521  (PRINC '|Should be seeking between cylinders 0 and |)
522  (LET ((BASE 10.) (*NOPOINT NIL))
523    (PRIN1 CYL))
524  (PRINC '| - type space when OK. |)
525  (DO () (#M (NOT (ZEROP (LISTEN))) #Q (KBD-TYI-NO-HANG))
526    (DC-SEEK 0)
527    (DC-SEEK CYL))
528  #M (TYI)
529  (TERPRI))
530
531;;; Basic XBUS errors call this guy, which prints a message and enters a test loop.
532(DEFUN DCHECK-ERR-LOOP (MESSAGE ADR VAL1 VAL2)
533  (TERPRI)
534  (PRINC MESSAGE)
535  (TERPRI)
536  (PRINC '|Now entering scope loop, writing |)
537  (PRIN1 VAL1)
538  (COND ((NOT (= VAL1 VAL2))
539         (PRINC '| and |)
540         (PRIN1 VAL2)))
541  (PRINC '| into |)
542  (PRIN1 ADR)
543  (PRINC '| and reading it back.|)
544  (DO () (#Q (KBD-TYI-NO-HANG) #M (LISTEN))
545    (PHYS-MEM-WRITE ADR VAL1)
546    (PHYS-MEM-READ ADR)
547    (PHYS-MEM-WRITE ADR VAL2)
548    (PHYS-MEM-READ ADR)))
549
550;;; ECC Test (in DCFU) error-message printer
551
552;;; This frob goes with the ECC tester in DCFU
553;;; He prints out the results of the log, which
554;;; are in page 28.
555;;; Each frob has status, ecc, bit mask, preceding word,
556;;; error word, next word.
557;;; The background is 0's.
558;;; The special variable ecc-wd-no is the bit corresponding
559;;; to a-ecc-wd in the ucode.
560
561(declare (special ecc-wd-no))
562
563(defun decode-ecc-logout ()
564  (do ((bitno 0 (1+ bitno))
565       (real-bitno (* 32. ecc-wd-no) (1+ real-bitno))
566       (logout-pntr (* 28. 400) (+ logout-pntr 6)))
567      ((= bitno 32.))
568    (declare (fixnum bitno real-bitno logout-pntr
569                     sts ecc msk prev-wd err-wd next-wd))
570    (let ((sts (phys-mem-read-24 logout-pntr))
571          (ecc (phys-mem-read (+ logout-pntr 1)))
572          (msk (phys-mem-read (+ logout-pntr 2)))
573          (prev-wd (phys-mem-read (+ logout-pntr 3)))
574          (err-wd (phys-mem-read (+ logout-pntr 4)))
575          (next-wd (phys-mem-read (+ logout-pntr 5))))
576      #M (or (= msk (lsh 1 bitno))
577             (break msk-bites-the-fucking-bag t))
578      (cond ((bit-test (logxor dc-all-error-bits 1_17) sts) ;all errs except ecc soft
579             (dc-print-status1 sts)
580             (format t '| error for bit ~D.| real-bitno))
581            ((not (LDB-TEST 1701 sts)) ;Bit 15.
582             (format t '|~%missing ecc soft error bit ~D.| real-bitno))
583            (t  ;Soft error, check pattern
584             (do ((pat (logldb 2013 ecc) (lsh pat -1))
585                  (pos (1- (logldb 0020 ecc)) (1+ pos)))
586                 ((oddp pat)
587                  (cond ((and (= pat 1) (= pos real-bitno)))
588                        (t (format t '|~%soft err wrong bit ~D., pos=~D.-1, pat=~O (i.e. ~D., ~O)|
589                                      real-bitno (logldb 0020 ecc)
590                                      (logldb 2013 ecc) pos pat))))
591               (declare (fixnum pos pat)))))
592      ;; Also check out the data read in
593      (and (> real-bitno 40)
594           (not (zerop prev-wd))
595           (format t '|~%For bit ~D., prev wd ~O should be 0|
596                     real-bitno prev-wd))
597      (and (not (= err-wd msk))
598           (format t '|~%For bit ~D., err wd ~O should be ~O|
599                     real-bitno err-wd msk))
600      (and (< real-bitno (- (* 256. 32.) 40))
601           (not (zerop next-wd))
602           (format t '|~%For bit ~D., next wd ~O should be 0|
603                     real-bitno next-wd))
604      )))
605
606;;; Read/Write test
607
608(declare (special dc-write-read-trace))
609(setq dc-write-read-trace t)
610
611;;; Low-level routine, does a write and a read and compares
612;;; Intended to run on Lisp machine.
613;;; Uses memory page 200 for buffer and loc 777 for CCW
614(defun dc-write-read-test-0 (cyl head blk pattern-func &aux offset)
615  (setq offset 100000)  ;use this page of main memory
616  ;; Trace
617  (and dc-write-read-trace
618       (format t '|~%WRITE-READ-TEST: cyl=~O, head=~O, blk=~O, pattern=~A|
619                 cyl head blk pattern-func))
620  ;; Fill memory with pattern
621  (do i 0 (1+ i) (= i 400)
622    (phys-mem-write (+ offset i) (funcall pattern-func i)))
623  ;; Write it out
624  (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits)
625  (do i 0 (1+ i) (= i 400)
626      (phys-mem-write (+ offset i) 0))
627  ;; Read it back
628  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits) 
629  ;; Check pattern
630  (do ((i 0 (1+ i))
631       (good) (bad) (heading-printed nil))
632      ((= i 400))
633    (setq good (funcall pattern-func i)
634          bad (phys-mem-read (+ offset i)))
635    (cond ((not (= good bad))
636           (cond ((not heading-printed)
637                  (format t '|~% Compare error for ~A pattern, cyl ~O, head ~O, blk ~O:~%Loc    Good      Bad|
638                            pattern-func cyl head blk)
639                  (setq heading-printed t)))
640           (format t '|~%~3O  ~8O ~8O| i good bad)))))
641
642;;; Patterns for above
643(defun all-zero-pat (ignore) 0)
644(defun all-one-pat (ignore) 37777777777)
645(defun alt-bits-pat (ignore) 25252525252)
646(defun addr-pat (loc) (+ (lsh (logxor 377 loc) 8) loc))
647(defun floating-one-pat (loc) (logdpb 1 (1+ (lsh (\ loc 40) 6)) 0))
648(defun floating-zero-pat (loc) (logdpb 0 (1+ (lsh (\ loc 40) 6)) 37777777777))
649(declare (special gubbish))
650(setq gubbish 7700770066)
651(defun gubbish-pat (ignore) gubbish)
652
653;;; Uses memory page 200 for buffer and loc 777 for CCW
654(defun dc-read-test-0 (cyl head blk ignore &aux offset)
655  (setq offset 100000)  ;use this page of main memory
656  ;; Trace
657  (and dc-write-read-trace
658       (format t "~%READ-TEST: cyl=~O, head=~O, blk=~O"
659                 cyl head blk))
660  ;; Read it
661  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits) 
662)
663
664;;; An address specifier is a single number, a list of cases,
665;;; or a list of DO, first, last, optional increment,
666;;; or (on typein) ALL which translates into such.
667;;; We cons current state onto the front
668;;; First value is next value output from spec, second value is T if wrapped around
669(defun dc-step-addr-spec (frob)
670  (prog ((current (car frob)) (spec (cdr frob)))
671    (cond ((atom spec)
672           (return spec t))
673          ((not (eq (car spec) 'do)) ;Cases list
674           (and (null current) (setq current 0))
675           (return (nth current spec)
676                   (progn (setq current (1+ current))
677                          (cond ((>= current (length spec))
678                                 (rplaca frob 0) t)
679                                (t (rplaca frob current) nil)))))
680          (t (and (null current) (setq current (cadr spec)))
681             (return current
682                     (progn (setq current (+ current (or (cadddr spec) 1)))
683                            (cond ((>= current (caddr spec))
684                                   (rplaca frob (cadr spec)) t)
685                                  (t (rplaca frob current) nil))))))))
686
687;;; Step a bunch of addr specs, return list of current state of each one.
688;;; First steps first, list returned is in reverse order
689(defun dc-step-addr-specs (specs)
690  (do ((l specs (cdr l))
691       (val)(wrap-p)
692       (r nil))
693      ((null l) r)
694    (multiple-value (val wrap-p) (dc-step-addr-spec (car l)))
695    (setq r (cons val r))
696    (cond ((not wrap-p)  ;Rest don't step
697           (return (do ((l (cdr l) (cdr l))
698                        (current) (spec)
699                        (r r))
700                       ((null l) r)
701                     (setq current (caar l) spec (cdar l))
702                     (setq r (cons (cond ((atom spec) spec)
703                                         ((eq (car spec) 'do)
704                                          (or current (cadr spec)))
705                                         (t (and (null current) (setq current 0))
706                                            (and (>= current (length spec)) (setq current 0))
707                                            (nth current spec)))
708                                   r))))))))
709
710(defun dc-get-addr-spec (prompt all &optional response)
711  (let ((spec (cond (response)
712                    (t
713                      (format t '|~% ~A:| prompt)
714                      (cond ((= (tyipeek) #/?)
715                             (tyi)
716                             (prin1 all)))
717                      (si:read-for-top-level)))))
718    (and (eq spec 'all) (setq spec all))
719    (cons nil spec)))
720
721(defun dc-get-addr-specs (response-list all-list &optional no-pattern)
722 (prog nil
723  (let ((cyl (dc-get-addr-spec '|Cylinders|
724                               (first all-list)
725                               (first response-list)))
726        (head (dc-get-addr-spec '|Heads|
727                                (second all-list)
728                                (second response-list)))
729        (blk (dc-get-addr-spec '|Blocks (sectors)|
730                               (third all-list)
731                               (third response-list)))
732        (pattern-func (if no-pattern (cons nil nil)
733                          (dc-get-addr-spec '|Pattern func|
734                                            '(all-zero-pat all-one-pat alt-bits-pat
735                                              addr-pat floating-one-pat floating-zero-pat
736                                              gubbish-pat)
737                                            (fourth response-list)))))
738    (return cyl head blk pattern-func))))
739
740;;; User interface to write-read test
741;;; This version is kludged up, you should step only one addr at a time!
742(defun dc-write-read-test (&optional response-list
743                                     (all-list (if marksman-p
744                                                   '( (do 0 210.)
745                                                      (do 0 4)
746                                                      (do 0 21.))
747                                                   '( (do 0 815.)
748                                                      (do 0 5)
749                                                      (do 0 17.) ))))
750  (multiple-value-bind (cyl head blk pattern-func)
751      (dc-get-addr-specs response-list all-list)
752    (do () ((kbd-char-available))
753      (apply 'dc-write-read-test-0
754             (dc-step-addr-specs (list pattern-func blk head cyl))))))
755
756(defun dc-wrt ()
757  (dc-write-read-test '(all all all all)))
758
759(defun dc-read-test (&optional response-list (all-list (if marksman-p
760                                                           '( (do 0 210.)
761                                                              (do 0 4)
762                                                              (do 0 21.))
763                                                           '( (do 0 815.)
764                                                              (do 0 5)
765                                                              (do 0 17.) ))))
766  (multiple-value-bind (cyl head blk pattern-func)
767      (dc-get-addr-specs response-list all-list T)
768    (do () ((kbd-char-available))
769      (apply 'dc-read-test-0
770             (dc-step-addr-specs (list pattern-func blk head cyl))))))
771
772;Useful for debugging disk problems, particularly read-compare errors
773(defvar copy-page-buffer)
774
775(defun copy-page (start-address)
776  (or (boundp 'copy-page-buffer) (setq copy-page-buffer (make-array nil 'art-q page-size)))
777  (dotimes (i page-size)
778    (aset (phys-mem-read (+ start-address i)) copy-page-buffer i)))
779
780(defun compare-page (start-address)
781  (dotimes (i page-size)
782    (let ((old (aref copy-page-buffer i))
783          (new (phys-mem-read (+ start-address i))))
784      (cond ((not (= old new))
785             (format t "~&~O// old ~O new ~O, xor ~O bits "
786                       (+ start-address i) old new (logxor old new))
787             (do ((bitlist nil)
788                  (bits (logxor old new))
789                  (bitno 0 (1+ bitno)))
790                 ((= bitno 32.)
791                  (cc-print-bit-list "" bitlist))
792               (and (bit-test (ash 1 bitno) bits)
793                    (push bitno bitlist))))))))
794
795(defun dc-repeat-read (cyl head sec &optional (error-bits dc-all-error-bits)
796                                    &aux (offset 100000))
797  (do () (())
798    (dc-exec dc-read cyl head sec 777 (+ offset 0) error-bits)))
799
800;;; Formatting stuff
801;;; This is too slow for bulk use, but useful for figuring out how you've lost.
802
803;Routines to access "buffer" memory, which is a bunch of halfwords
804;starting at XBUS address zero.
805
806;Since things seem very marginal, and for speed, we copy the stuff in and out
807;of an array, being careful while copying.
808
809(declare (special buffer-hwd buffer-bit))
810(or (boundp 'buffer-hwd)    ;20. pages for decode-track plus 1 for channel program
811    (setq buffer-hwd (make-array nil 'art-16b (* 1000 21.))
812          buffer-bit (make-array nil 'art-1b (* 1000 21. 16.)
813                                 buffer-hwd)))
814
815;Get buffer out of other machine
816(defun get-buffer ()
817  (dbg-reset-status)
818  (do ((i 0 (1+ i))
819       (tem) (tem1)
820       (n (array-length buffer-hwd)))
821      ((= i n))
822    (setq tem (rd-buffer i)
823          tem1 (rd-buffer i))
824    (or (= tem tem1)
825        (ferror nil "Halfword ~O read as ~O and as ~O" i tem tem1))
826    (as-1 tem buffer-hwd i))
827  (dbg-print-status))
828
829;Put buffer into other machine
830(defun put-buffer ()
831  (dbg-reset-status)
832  (do ((i 0 (1+ i))
833       (tem)(tem1)
834       (n (array-length buffer-hwd)))
835      ((= i n))
836    (wr-buffer i (setq tem (ar-1 buffer-hwd i)))
837    (setq tem1 (rd-buffer i))
838    (or (= tem tem1)
839        (ferror nil "Halfword ~O wrote ~O read back as ~O" i tem tem1)))
840  (dbg-print-status))
841
842(defun rd-buffer (loc)
843  (let ((ubus-loc (dbg-setup-unibus-map 17 (lsh loc -1))))
844     (cond ((zerop (logand 1 loc))
845            (dbg-read ubus-loc))
846           (t (dbg-read ubus-loc)
847              (dbg-read (+ ubus-loc 2))))))
848
849(defun wr-buffer (loc val)
850  (let ((ubus-loc (dbg-setup-unibus-map 17 (lsh loc -1))) (tem))
851     (cond ((zerop (logand 1 loc))
852            (dbg-read ubus-loc)
853            (dbg-write ubus-loc val)
854            (dbg-write (+ ubus-loc 2) (setq tem (dbg-read (+ ubus-loc 2))))
855            ;(ck-buffer loc val tem (dbg-read ubus-loc) (dbg-read (+ ubus-loc 2)))
856            )
857           (t (dbg-write ubus-loc (setq tem (dbg-read ubus-loc)))
858              (dbg-write (+ ubus-loc 2) val)
859              ;(ck-buffer loc tem val (dbg-read ubus-loc) (dbg-read (+ ubus-loc 2)))
860              ))))
861
862(defun ck-buffer (loc good1 good2 wd1 wd2)
863     (or (and (= good1 wd1)
864              (= good2 wd2))
865         (ferror nil "Loc ~O wrote ~O,,~O, read ~O,,~O" loc good2 good1 wd2 wd1)))
866
867;Given a loc in the buffer, and a disk address, store a sector whose header
868;claims it is at that address, and return the advanced loc.
869;This uses the copy of the buffer in this machine.
870(defun store-sector (loc cyl head blk next-address-code)
871  ;;Preamble+VFO lock is 61. bytes of 1's, followed by sync which is a 177
872  (do i 30. (1- i) (= i 0)              ;Store 60. bytes (30. halfwords) of 1's
873    (as-1 177777 buffer-hwd loc)
874    (setq loc (1+ loc)))
875  (as-1 077777 buffer-hwd loc)          ;One byte of 1's and a byte of 177
876  (setq loc (1+ loc))
877  ;;Header.  A 32-bit word, see the manual for format.
878  ;;Followed by 32 bits of ecc.
879  (let ((head1 (+ (lsh head 8) blk))
880        (head2 (+ (lsh next-address-code 14.) cyl))
881        (ecc1 0)
882        (ecc2 0))
883     (as-1 head1 buffer-hwd loc)
884     (as-1 head2 buffer-hwd (1+ loc))
885     (multiple-value (ecc1 ecc2) (ecc16 head1 ecc1 ecc2))
886     (multiple-value (ecc1 ecc2) (ecc16 head2 ecc1 ecc2))
887     (as-1 ecc1 buffer-hwd (+ loc 2))
888     (as-1 ecc2 buffer-hwd (+ loc 3))
889     (setq loc (+ loc 4)))
890  ;;VFO Relock - 20. bytes of 1's
891  (do i 10. (1- i) (= i 0)
892    (as-1 177777 buffer-hwd loc)
893    (setq loc (1+ loc)))
894  ;;Sync (177) and pad (377)
895  (as-1 177577 buffer-hwd loc)
896  (setq loc (1+ loc))
897  ;;Data field - 1024. bytes of zeros.
898  (do i 512. (1- i) (= i 0)
899    (as-1 0 buffer-hwd loc)
900    (setq loc (1+ loc)))
901  ;;Data ecc, doesn't matter anyway, we'll just write zero (which is right for zero)
902  (as-1 0 buffer-hwd loc)
903  (setq loc (1+ loc))
904  (as-1 0 buffer-hwd loc)
905  (setq loc (1+ loc))
906  ;;Postamble, 44. bytes of 1's
907  (do i 22. (1- i) (= i 0)
908    (as-1 177777 buffer-hwd loc)
909    (setq loc (1+ loc)))
910  loc)
911
912;Compute ECC for 16 bits, given previous ecc halfword pair and returning new
913(defun ecc16 (hwd ecc1 ecc2)
914  (do ((i 16. (1- i))
915       (hwd hwd (lsh hwd -1))
916       (bit) (poly1) (poly2))
917      ((zerop i) (return ecc1 ecc2))
918    (setq bit (logxor (logand 1 hwd) (logand 1 ecc1)))  ;ecc.in
919    (setq poly1 (* bit 002400)  ;1's in bits 8, 10
920          poly2 (* bit 120020)) ;1's in bits 20, 29, 31
921    (setq ecc1 (+ (lsh ecc1 -1) ;Shift double right 1
922                  (lsh (logand 1 ecc2) 15.))
923          ecc2 (lsh ecc2 -1))
924    (setq ecc1 (logxor ecc1 poly1)
925          ecc2 (logxor ecc2 poly2))))
926
927;Format a track.  Method is call store-sector enough times
928;to make most of the 20160. bytes of the track (better to err on the side
929;of less than more.)  Then set up a channel program and run the disk
930;to write it all out.
931(defun format-track (cyl head &aux loc)
932  ;;First page is used for channel program
933  (setq loc 1000) ;halfwords
934  (do blk 0 (1+ blk) (= blk 17.)
935    (setq loc (store-sector loc cyl head blk
936                            (cond ((< blk 16.) 0) ;next block same track
937                                  ((< head 4) 1) ;block 0 next track
938                                  ((< cyl 815.) 2) ;block 0, head 0, next cylinder
939                                  (t 3)))))    ;end of disk
940  (put-buffer) ;ship it over
941  ;;Always write 19 pages, somewhat of a crock, should look at loc
942  (do i 0 (1+ i) (= i 19.)
943    (dbg-write-xbus i (+ (lsh (1+ i) 8)
944                         (cond ((= i 18.) 0) (t 1)))))
945  ;;Do it
946  (dc-exec dc-write-all cyl head 0 0 nil dc-some-error-bits)
947  )
948
949(declare (special trklen))
950(setq trklen (* 20160. 8))
951
952;This function reads in a track and types out some approximation of what's on it
953;If cyl is nil, decode what's in core
954(defun decode-track (cyl head &optional (blk 0))
955  (cond ((not (null cyl))
956         ;; First, read in 20. blocks, which is more than 20160. bytes
957         (do i 0 (1+ i) (= i 20.)
958           (dbg-write-xbus i (+ (lsh (1+ i) 8)
959                                (cond ((= i 19.) 0) (t 1))))) 
960         (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits)
961         (get-buffer) ;gobble it down from other machine
962         ))
963  ;; Map over sectors
964  (do ((loc 0)
965       (hwd1) (hwd2))
966      ((or (> loc trklen) (kbd-tyi-no-hang)))
967    (setq loc (decode-sync loc))
968    (cond ((< loc trklen)
969           (setq hwd1 (rd-hwd loc)
970                 hwd2 (rd-hwd (setq loc (+ loc 20)))
971                 loc (+ loc 20))
972           (format t "~%Header: ~O,,~O" hwd2 hwd1)
973           (setq hwd1 (rd-hwd loc)
974                 hwd2 (rd-hwd (setq loc (+ loc 20)))
975                 loc (+ loc 20))
976           (format t " ... ecc ~O,,~O" hwd2 hwd1)
977           (setq loc (decode-sync loc)) ;VFO relock
978           (format t "~% Pad, data, ecc: ")
979           (decode-bits loc (* 8 1029.))
980           (setq loc (+ loc (* 8 1029.)))))))
981
982;Get a bit out of the buffer, given a bit loc
983(defmacro rd-bit (loc)
984  `(ar-1 buffer-bit (+ 20000 ,loc)))  ;8K bits of first page skipped
985
986(defmacro wr-bit (loc val)
987  `(as-1 ,val buffer-bit (+ 20000 ,loc)))  ;8K bits of first page skipped
988
989;Get a 16-bit halfword, given a bit loc.
990(defun rd-hwd (loc)
991  (do ((hwd 0 (+ (lsh hwd -1) (lsh (rd-bit (+ loc i)) 15.)))
992       (i 0 (1+ i)))
993      ((= i 20) hwd)))
994
995;Just type out some bits run-length encoded
996(defun decode-bits (loc nbits)
997  ;;Do forever, until field exhausted
998  (do ((endloc (+ loc nbits)))
999      ((>= loc endloc))
1000    ;;Skip zeros
1001    (do ((zerc 0 (1+ zerc)))
1002        ((or (>= loc endloc)
1003             (not (zerop (rd-bit loc))))
1004         (or (zerop zerc)
1005             (format t "~D zeros " zerc)))
1006      (setq loc (1+ loc)))
1007    ;;Skip ones
1008    (do ((onec 0 (1+ onec)))
1009        ((or (>= loc endloc)
1010             (zerop (rd-bit loc)))
1011         (or (zerop onec)
1012             (format t "~D ones " onec)))
1013      (setq loc (1+ loc)))))
1014
1015;Find a sync, type out 1's and 0's
1016;A sync is at least 64 1's followed by a 0.
1017(defun decode-sync (loc)
1018  (and (zerop (rd-bit loc))             ;Skip leading zeros
1019       (do ((zerc 1 (1+ zerc)))
1020           ((or (not (zerop (rd-bit (setq loc (1+ loc)))))
1021                (> loc trklen))
1022            (format t "~%~D zeros" zerc))))
1023  (do ((onec 1 (1+ onec)))              ;Skip ones
1024      ((or (zerop (rd-bit (setq loc (1+ loc))))
1025           (> loc trklen))
1026       (format t "~%~D ones" onec)
1027       (cond ((> loc trklen) loc)
1028             ((>= onec 64.)
1029              (format t " 1 zero")
1030              (1+ loc)) ;Skip the zero
1031             (t (decode-sync loc))))))
1032
1033;Simulated ECC errors.
1034(declare (special rd-all-wrt-all-offset))
1035(setq rd-all-wrt-all-offset 4)  ;Offset in halfwords
1036
1037;The method is to read in a whole track, as 20 pages, then shift it down
1038;in buffer memory by the offset, to compensate for the way the hardware works.
1039;Next, find a specified bit in the data area of sector 0 and corrupt it.
1040;Then write the whole track back, as 19 pages.  This destroys sector 16., unfortunately.
1041;Now, read in sector 0, take the ECC error, and see if it is the correct bit.
1042
1043;This function gets a track into core and offsets it
1044(defun read-whole-track (cyl head)
1045  ;; First, read in 20. blocks, which is more than 20160. bytes
1046  (do i 0 (1+ i) (= i 20.)
1047    (dbg-write-xbus i (+ (lsh (1+ i) 8)
1048                         (cond ((= i 19.) 0) (t 1))))) 
1049  (dc-exec dc-read-all cyl head 0 0 nil dc-some-error-bits)
1050  (get-buffer) ;gobble it down from other machine
1051  ;; Offset the buffer (not the first page)
1052  (do i (1- 25000) (1- i) (= i 1000)
1053    (as-1 (cond ((>= (- i rd-all-wrt-all-offset) 1000)
1054                 (ar-1 buffer-hwd (- i rd-all-wrt-all-offset)))
1055                (t 177777))
1056                buffer-hwd i))
1057  )
1058
1059;This function writes a track back out
1060(defun write-whole-track (cyl head)
1061  (put-buffer) ;ship it over
1062  ;;Always write 19 pages, somewhat of a crock, should look at loc
1063  (do i 0 (1+ i) (= i 19.)
1064    (dbg-write-xbus i (+ (lsh (1+ i) 8)
1065                         (cond ((= i 18.) 0) (t 1)))))
1066  ;;Do it
1067  (dc-exec dc-write-all cyl head 0 0 nil dc-some-error-bits)
1068  )
1069
1070;This function finds the start of sector 0 in the buffer and corrupts
1071;a specified bit in it.
1072;Find 64 1's, followed by a 0.  Skip 64-bit header, again find 64 1's
1073;followed by a 0.  Skip 8 bits and you are at the first data bit.
1074(defun corrupt-bit (bitno)
1075  (let ((start (+ 8. (find-sync (+ 64. (find-sync 0))))))
1076    (wr-bit (+ start bitno) (- 1 (rd-bit (+ start bitno))))))
1077
1078;This function tests 1 bit
1079(defun test-ecc-1 (cyl head bitno)
1080  (read-whole-track cyl head)
1081  (corrupt-bit bitno)
1082  (write-whole-track cyl head)
1083  ;; Now read block 0 into page 1
1084  (dbg-write-xbus 0 400)
1085  (dc-exec dc-read cyl head 0 0 nil dc-some-error-bits)
1086  (let ((sts (phys-mem-read-24 dc-sts-adr))
1087        (ecc-loc (phys-mem-read dc-ecc-adr))
1088        ecc-pat)
1089    (setq ecc-pat (ldb 2020 ecc-loc)
1090          ecc-loc (ldb 0020 ecc-loc))
1091    (cond ((not (and (bit-test (lsh 1 15.) sts) ;ECC-SOFT should be set
1092                     (not (bit-test (lsh 476775 6) sts)))) ;IPE, ECC-HARD, etc. should not be
1093           (dc-print-status1 sts))
1094          ((zerop ecc-pat) (format t "~%Error, ecc-pat is 0, loc=~O~%" ecc-loc))
1095          ((do ((loc ecc-loc (1+ loc))
1096                (pat ecc-pat (lsh pat -1)))
1097               ((oddp pat)
1098                (cond ((not (= pat 1))
1099                       (format t "~%Error, more than one bit on in pat, pat=~O, loc=~O~%"
1100                                 pat loc))
1101                      ((not (= loc bitno))
1102                       (format t "~%Error, wrong bit number, pat=1, loc=~O~%" loc))
1103                      (t  ;OK
1104                       ))))))))
1105
1106;This function stores specified crud in sector 0
1107(defun fill-sec0 (cyl head patname)
1108  (do i 0 (1+ i) (= i 1000)
1109    (wr-buffer (+ i 1000)
1110               (selectq patname
1111                 (zero 0)
1112                 (one 177777)
1113                 (addr i)
1114                 (caddr (logxor 177777 i))
1115                 (rot1 (lsh 1 (\ i 20)))
1116                 (rot0 (logxor 177777 (lsh 1 (\ i 20))))
1117                 (otherwise (ferror nil "Unknown pattern name ~S, try zero, one, addr, caddr, rot1, or rot0" patname)))))
1118  (dc-exec dc-write cyl head 0 0 400 dc-all-error-bits))
1119
1120;This function finds a sync pattern, which is at least 64 1's followed by a 0.
1121(defun find-sync (loc)
1122  (and (zerop (rd-bit loc))             ;Skip leading zeros
1123       (do ((zerc 1 (1+ zerc)))
1124           ((or (not (zerop (rd-bit (setq loc (1+ loc)))))
1125                (> loc trklen)))))
1126  (do ((onec 1 (1+ onec)))              ;Skip ones
1127      ((or (zerop (rd-bit (setq loc (1+ loc))))
1128           (> loc trklen))
1129       (cond ((> loc trklen) loc)
1130             ((>= onec 64.)
1131              (1+ loc)) ;Skip the zero
1132             (t (find-sync loc))))))
Note: See TracBrowser for help on using the repository browser.