source: trunk/lisp/lcadr/diags.lisp @ 205

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

Update.

File size: 79.3 KB
Line 
1;;; -*-LISP-*-
2;;; Cadr diagnositics
3
4(INCLUDE |LMDOC;.COMPL PRELUD|)
5
6(IF-FOR-MACLISP (DECLARE (EVAL (READ))))
7(IF-FOR-MACLISP (DEFUN **STRING** MACRO (X) `',(CADR X)) )
8
9(INCLUDE ((LMCONS)CADMAC >))
10
11(IF-FOR-MACLISP
12(DECLARE (FIXNUM (ROT32 FIXNUM FIXNUM)))
13(DEFUN ROT32 (NUM AMT)  ;FIXNUM VERSION OF 32-BIT ROTATE ROUTINE (ONLY ROTATES LEFT)
14  (LOGAND 37777777777 (+ (LSH NUM AMT) (LOGAND (1- (LSH 1 AMT))
15                                               (ROT NUM (+ 4 AMT)))))) )
16
17(IF-FOR-LISPM
18(DEFUN ROT32 (NUM AMT)
19  (LOGAND 37777777777
20          (COND ((< AMT 30) (+ (ASH NUM AMT) (LDB (+ (LSH (- 40 AMT) 6) AMT) NUM)))
21                (T (DPB (LDB (- 40 AMT) NUM)
22                        (+ (LSH AMT 6) (- 40 AMT))
23                        (ASH NUM (- AMT 40))))))) )
24
25(DEFMACRO ONES-COMPLEMENT (X)  ;Can't use LOGXOR with -1 on bignums!
26  `(BOOLE 14 0 ,X))
27
28;;; Function for scoping.  Stop when a key hit.  Only forms which evaluate their
29;;; arguments allowed here.
30
31(DEFUN CC-LOOP (FORM)
32  (DO ((FCN (CAR FORM))
33       (ARGS (MAPCAR #'EVAL (CDR FORM))))
34      ((KBD-TYI-NO-HANG))
35    (APPLY FCN ARGS)))
36
37(DECLARE (SPECIAL ALL-DATA-PATHS ALL-MEMORIES CC-LOW-LEVEL-FLAG CC-DIAG-TRACE))
38(SETQ ALL-DATA-PATHS
39      '(CC-TEST-IR-DP CC-TEST-PC-DP CC-TEST-MD-DP CC-TEST-VMA-DP
40        CC-TEST-M-MEM-DP CC-TEST-A-MEM-DP
41        CC-TEST-PP-DP CC-TEST-PI-DP CC-TEST-PDL-DP CC-TEST-Q-DP CC-TEST-C-MEM-DP
42        CC-TEST-LC-DP CC-TEST-A-PASS-DP CC-TEST-M-PASS-DP
43        CC-TEST-ALU-SHIFT-LEFT-DP CC-TEST-ALU-SHIFT-RIGHT-DP
44        CC-TEST-UNIBUS-MAP-DP CC-TEST-BUSINT-BUFFERS-DP))
45(SETQ ALL-MEMORIES
46      `( (M-MEM ,RAMMO 32. 5.)
47         (A-MEM ,RAAMO 32. 10.)
48         (PDL-BUFFER ,RAPBO 32. 10.)
49         (C-MEM ,RACMO 48. 14.)
50         (D-MEM ,RADMO 16. 11.)
51;NOTE, CAN'T TEST BIT 16 OF D-MEM (R-BIT)
52         (SPC ,RAUSO 19. 5.)
53         (LEVEL-1-MAP ,RAM1O 5. 11.)
54         (LEVEL-2-MAP ,RAM2O 24. 10.)
55         (UNIBUS-MAP ,RAUBMO 16. 4) ))
56
57;;; Toplevel machine checking
58(DEFUN CC-TEST-MACHINE ()
59   (LET ((CC-LOW-LEVEL-FLAG 'VERY))
60     (FORMAT T "~&For best results, ground -TPTSE, 1C07-09 on CMEM boards~%")
61      (PRINT 'RESET)
62      (DBG-RESET)               ;Forcibly reset the whole machine
63      (CC-RESET-MACH)           ;Now set to the correct mode
64      (CC-TEST-DATA-PATHS ALL-DATA-PATHS)
65      (CC-FAST-ADDRESS-TESTS ALL-MEMORIES)
66      (CC-FAST-ADDRESS-TEST-C-MEM-BANKS)
67      (CC-TEST-SPC-POINTER)
68      (CC-TEST-SHIFTER-LOGIC)
69      (CC-TEST-OA-REGS)
70      (CC-TEST-DISPATCH)
71      (CC-TEST-CLOCK)
72      NIL))
73
74(DEFUN CC-TEST-SHIFTER-LOGIC ()
75  (FORMAT T "~&CC-TEST-SHIFTER-LOGIC~%")
76  (CC-TEST-MASK-LEFT)
77  (CC-TEST-MASK-RIGHT)
78  (CC-TEST-MASKER)
79  (CC-TEST-SHIFTER)
80  (CC-TEST-LC-AFFECTS-SHIFT))
81
82(DEFUN CC-TEST-DATA-PATHS (DATA-PATH-LIST)
83   (MAPC (FUNCTION (LAMBDA (FUNCTION)
84                       (PRINT FUNCTION)
85                       (APPLY FUNCTION NIL)))
86         DATA-PATH-LIST))
87
88(DEFUN CC-FAST-ADDRESS-TESTS (MEMORIES-LIST)
89   (TERPRI)
90   (MAPC (FUNCTION (LAMBDA (X)
91                       (PRIN1 'CC-FAST-ADDRESS-TEST)
92                       (TYO 40)
93                       (PRIN1 (CAR X))
94                       (TERPRI)
95                       (APPLY 'CC-FAST-ADDRESS-TEST X)))
96         MEMORIES-LIST))
97
98(DEFUN CC-GROSS-DATA-TESTS (MEMORIES-LIST)
99   (LET ((CC-LOW-LEVEL-FLAG 'VERY))
100     (PRINT 'RESET)
101     (DBG-RESET)                ;Forcibly reset the whole machine
102     (CC-RESET-MACH)            ;Now set to the correct mode
103     (TERPRI)
104     (MAPC (FUNCTION (LAMBDA (X)
105                       (PRIN1 'CC-GROSS-DATA-TEST)
106                       (TYO 40)
107                       (PRIN1 (CAR X))
108                       (TERPRI)
109                       (APPLY 'CC-GROSS-DATA-TEST X)))
110           MEMORIES-LIST)))
111
112(DEFUN CC-OTHER-TESTS NIL
113  (PRINT 'CC-TEST-PC-INCREMENTER)
114  (CC-TEST-PC-INCREMENTER)
115  (PRINT 'CC-TEST-SPY-IR)
116  (CC-TEST-SPY-IR)
117  (PRINT 'CC-TEST-INCREMENTER)
118  (CC-TEST-INCREMENTER)
119  (PRINT 'CC-TEST-ARITH-COND-JUMP)
120  (CC-TEST-ARITH-COND-JUMP)
121  (PRINT 'CC-ADDRESS-TEST-A-MEM)
122  (CC-ADDRESS-TEST-A-MEM)
123  (PRINT 'CC-TEST-M-MEM-ADR)
124  (CC-TEST-M-MEM-ADR)
125  (PRINT 'CC-TEST-A-MEM-ADR)
126  (CC-TEST-A-MEM-ADR)
127  (PRINT 'CC-TEST-PDL-ADR)
128  (CC-TEST-PDL-ADR))
129
130;Test each 4K separately since they have separate address drivers
131(DEFUN CC-FAST-ADDRESS-TEST-C-MEM-BANKS (&OPTIONAL (NBANKS 3))
132  (FORMAT T "CC-FAST-ADDRESS-TEST-C-MEM-BANKS~%")
133  (DOTIMES (BANK NBANKS)
134    (CC-FAST-ADDRESS-TEST
135      (FORMAT NIL "CMEM-BANK ~A" BANK) (+ RACMO (* BANK 10000)) 48. 12.)))
136
137
138;;; Toplevel data path tests
139
140(DEFUN CC-TEST-IR-DP ()
141  (CC-TEST-DATA-PATH "Unibus -> DEBUG-IR -> IR -> Unibus" RAIR 48.))
142
143(DEFUN CC-TEST-PC-DP ()
144  (CC-TEST-DATA-PATH "Unibus -> IR(Jump) -> PC -> Unibus" RAPC 14.))
145
146(DEFUN CC-TEST-MD-DP ()
147  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> MF -> M -> ALU -> Obus -> Unibus" RAMD 32.))
148
149(DEFUN CC-TEST-VMA-DP ()
150  (CC-TEST-DATA-PATH "(Unibus -> Xbus -> MD -> MF -> M -> ALU -> Obus) ->
151 VMAS -> VMA -> MF -> M -> ALU -> Obus -> Unibus" RAVMA 32.))
152
153(DEFUN CC-TEST-M-MEM-DP ()
154  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> M-MEM -> M -> ALU -> Obus -> Unibus" RAMMO 32.))
155
156(DEFUN CC-TEST-M-MEM (&OPTIONAL (V1 0) (V2 -1) (ADR 1))
157  (DO () ((KBD-TYI-NO-HANG))
158    (CC-WRITE-M-MEM ADR V1)
159    (CC-READ-M-MEM ADR)
160    (CC-WRITE-M-MEM ADR V2)
161    (CC-READ-M-MEM ADR)))
162
163(DEFUN CC-TEST-A-MEM-DP ()
164  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> A-MEM -> ALU -> Obus -> Unibus" RAAMO 32.))
165
166(DEFUN CC-TEST-A-MEM (&OPTIONAL (V1 0) (V2 -1) (ADR 1))
167  (DO () ((KBD-TYI-NO-HANG))
168    (CC-WRITE-A-MEM ADR V1)
169    (CC-READ-A-MEM ADR)
170    (CC-WRITE-A-MEM ADR V2)
171    (CC-READ-A-MEM ADR)))
172
173(DEFUN CC-TEST-A-MEM-ADDRESSES NIL
174  (WITHOUT-INTERRUPTS
175    (DO ((ADR 1 (LSH ADR 1)))
176        ((KBD-TYI-NO-HANG))
177      (IF (> ADR 1000) (SETQ ADR 1))
178      (CC-WRITE-A-MEM ADR 0)
179      (CC-WRITE-A-MEM ADR -1))))
180
181(DEFUN CC-TEST-PP-DP ()
182  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> PP -> MF -> M -> ALU -> Obus -> Unibus"
183                     RAPP 10.))
184
185(DEFUN CC-TEST-PI-DP ()
186  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> PI -> MF -> M -> ALU -> Obus -> Unibus"
187                     RAPI 10.))
188
189(DEFUN CC-TEST-PDL-DP ()
190  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> PDL-Buffer -> M -> ALU -> Obus -> Unibus"
191                     RAPBO 32.))
192
193(DEFUN CC-TEST-PDL-ADDRESSES ()
194  (DO ((BIT 1 (IF (> BIT 1000) 1 (LSH BIT 1))))
195      ((KBD-TYI-NO-HANG))
196    (CC-R-D (+ RAPBO BIT) 0)))
197
198(DEFUN CC-TEST-Q-DP ()
199  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> ALU -> Q -> MF -> M -> ALU -> Obus -> Unibus"
200                     RAQ 32.))
201
202(DEFUN CC-TEST-C-MEM-DP ()
203  (CC-TEST-DATA-PATH
204"Unibus -> Xbus -> MD -> M-MEM ->
205Unibus -> Xbus -> MD -> A-MEM ->
206A-MEM & M-MEM -> IWR -> C-MEM -> IR(Jump) -> Unibus" RACMO 48.))
207
208(DEFUN CC-TEST-C-MEM (&OPTIONAL (V1 0) (V2 -1) (ADR 0))
209  (DO () ((KBD-TYI-NO-HANG))
210    (CC-WRITE-C-MEM ADR V1)
211    (CC-WRITE-C-MEM ADR V2)))
212
213(DEFUN CC-TEST-LC-DP ()
214  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-INT-CNTRL 1_29.)   ;SET LC BYTE MODE
215  (CC-TEST-DATA-PATH "Unibus -> Xbus -> MD -> LC -> MF -> M -> ALU -> Obus" RALC 26.))
216
217(DEFUN CC-TEST-A-PASS-DP ()
218  (CC-TEST-DATA-PATH "->L->APASS->A->ALU" '(CC-A-PASS-HANDLER) 32.))
219
220(DEFUN CC-TEST-M-PASS-DP ()
221  (CC-TEST-DATA-PATH "->L->MPASS->MF->M->ALU" '(CC-M-PASS-HANDLER) 32.))
222
223(DEFUN CC-TEST-ALU-SHIFT-LEFT-DP ()
224  (CC-TEST-DATA-PATH "MD,Q(31) -> ALU-SHIFT-LEFT-1" '(CC-ALU-SHIFT-LEFT-HANDLER) 32.))
225
226(DEFUN CC-TEST-ALU-SHIFT-RIGHT-DP ()
227  (CC-TEST-DATA-PATH "MD -> M+M -> ALU-SHIFT-RIGHT-1" '(CC-ALU-SHIFT-RIGHT-HANDLER) 32.))
228
229(DEFUN CC-TEST-UNIBUS-MAP-DP ()
230  (CC-TEST-DATA-PATH "Unibus Map" RAUBMO 16.))
231
232;Read and write Xbus location 0 through all 16 Unibus buffers
233(DEFUN CC-TEST-BUSINT-BUFFERS-DP ()
234  (COND ((EQ SPY-ACCESS-PATH 'BUSINT)
235         (DO DBG-UNIBUS-MAP-NUMBER 0 (1+ DBG-UNIBUS-MAP-NUMBER) (= DBG-UNIBUS-MAP-NUMBER 20)
236           (CC-TEST-DATA-PATH
237             (FORMAT NIL "Unibus->Buffer ~O->Xbus loc 0->Buffer ~O->Unibus"
238                         DBG-UNIBUS-MAP-NUMBER DBG-UNIBUS-MAP-NUMBER)
239             200000 32.)))))
240
241
242(DEFUN CC-A-PASS-HANDLER (OP DATA)
243  (SELECTQ OP
244    (WRITE-READ
245        (CC-WRITE-MD DATA)              ;PUT VALUE INTO THE MRD REGISTER
246        (CC-EXECUTE  ;NOTE NO WRITE, JUST PUT IT IN IR
247          CONS-IR-M-SRC CONS-M-SRC-MD   ;MOVE IT TO DESIRED PLACE
248          CONS-IR-ALUF CONS-ALU-SETM
249          CONS-IR-OB CONS-OB-ALU
250          CONS-IR-A-MEM-DEST (+ CONS-A-MEM-DEST-INDICATOR 0))
251        (CC-EXECUTE (EXECUTOR CC-EXECUTE-LOAD-DEBUG-IR)
252                    CONS-IR-A-SRC 0                     ;PUT IT ONTO THE OBUS
253                    CONS-IR-ALUF CONS-ALU-SETA
254                    CONS-IR-OB CONS-OB-ALU)
255        (CC-DEBUG-CLOCK)        ;EXECUTE THE WRITE, LOAD IR WITH THE READ
256        (LET ((ACTUAL (CC-READ-OBUS)))  ;READ BACK THE DATA VIA THE PASS AROUND PATH
257          (COND ((AND CC-DIAG-TRACE (NOT (= ACTUAL DATA)))
258                 (FORMAT T "~%A-PASS WROTE ~S READ ~S" DATA ACTUAL)))
259          ACTUAL))
260  (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
261
262(DEFUN CC-M-PASS-HANDLER (OP DATA)
263  (SELECTQ OP
264    (WRITE-READ
265      (CC-WRITE-MD DATA)                ;PUT VALUE INTO THE MRD REGISTER
266      (CC-EXECUTE  ;NOTE NO WRITE, JUST PUT IT IN IR
267        CONS-IR-M-SRC CONS-M-SRC-MD
268        CONS-IR-ALUF CONS-ALU-SETM
269        CONS-IR-OB CONS-OB-ALU
270        CONS-IR-M-MEM-DEST 0)           ;ADR
271      (CC-EXECUTE (EXECUTOR CC-EXECUTE-LOAD-DEBUG-IR)
272                  CONS-IR-M-SRC 0       ;PUT IT ONTO THE OBUS
273                  CONS-IR-ALUF CONS-ALU-SETM
274                  CONS-IR-OB CONS-OB-ALU)
275      (CC-DEBUG-CLOCK)  ;EXECUTE THE WRITE, LOAD IR WITH THE READ
276      (LET ((ACTUAL (CC-READ-OBUS)))    ;READ BACK THE DATA VIA THE PASS AROUND PATH
277        (COND ((AND CC-DIAG-TRACE (NOT (= ACTUAL DATA)))
278               (FORMAT T "~%M-PASS WROTE ~S READ ~S" DATA ACTUAL)))
279        ACTUAL))
280    (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
281
282(DEFUN CC-ALU-SHIFT-LEFT-HANDLER (OP DATA)
283  (SELECTQ OP
284    (WRITE-READ
285     (CC-WRITE-Q (ASH (LOGAND DATA 1) 31.))     ;low bit to high bit of Q
286     (CC-WRITE-MD (ASH DATA -1))
287     (CC-EXECUTE                                ;NOTE NO WRITE, JUST PUT IT IN IR
288       CONS-IR-M-SRC CONS-M-SRC-MD
289       CONS-IR-ALUF CONS-ALU-SETM
290       CONS-IR-OB CONS-OB-ALU-LEFT-1)
291     (LET ((ACTUAL (CC-READ-OBUS)))
292       (COND ((AND CC-DIAG-TRACE (NOT (= ACTUAL DATA)))
293              (FORMAT T "~%ALU-LEFT WROTE ~S READ ~S" DATA ACTUAL)))
294       ACTUAL))
295    (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
296
297(DEFUN CC-ALU-SHIFT-RIGHT-HANDLER (OP DATA)
298  (SELECTQ OP
299    (WRITE-READ
300     (CC-WRITE-MD DATA)
301     (CC-EXECUTE
302       CONS-IR-M-SRC CONS-M-SRC-MD
303       CONS-IR-ALUF CONS-ALU-M+M
304       CONS-IR-OB CONS-OB-ALU-RIGHT-1)
305     (LET ((ACTUAL (CC-READ-OBUS)))
306       (COND ((AND CC-DIAG-TRACE (NOT (= ACTUAL DATA)))
307              (FORMAT T "~%ALU-RIGHT WROTE ~S READ ~S" DATA ACTUAL)))
308       ACTUAL))
309    (OTHERWISE (FERROR NIL "UNKNOWN OP"))))
310
311;;; Numeric list operations
312
313(DEFMACRO NUMERIC-LIST-DELQ (N L)
314   `(SETQ ,L (DELQ ,N ,L)))
315
316(DEFUN NUMERIC-LIST-MEMQ (N L)
317  (DO ((L L (CDR L)))
318      ((NULL L) NIL)
319    (AND (= (CAR L) N)
320         (RETURN L))))
321
322(DEFUN NUMERIC-LIST-UNION (L1 L2)
323  (DO ((L L1 (CDR L))
324       (R L2))
325      ((NULL L) R)
326    (OR (NUMERIC-LIST-MEMQ (CAR L) R)
327        (SETQ R (CONS (CAR L) R)))))
328
329(DEFUN NUMERIC-LIST-INTERSECTION (L1 L2)
330  (DO ((L L1 (CDR L))
331       (R NIL))
332      ((NULL L) R)
333    (AND (NUMERIC-LIST-MEMQ (CAR L) L2)
334         (SETQ R (CONS (CAR L) R)))))
335
336(DEFUN NUMERIC-LIST-DIFFERENCE (L1 L2)
337  (DO ((L L1 (CDR L))
338       (R NIL))
339      ((NULL L) R)
340    (OR (NUMERIC-LIST-MEMQ (CAR L) L2)
341        (SETQ R (CONS (CAR L) R)))))
342
343
344;;; Data path internals
345
346(DEFUN CC-WRITE-AND-READ (REGADR DATA &OPTIONAL (MASK 37777777777))
347  (COND ((ATOM REGADR)
348         (CC-R-D REGADR DATA)
349         (LET ((ACTUAL (CC-R-E REGADR)))
350           (COND ((AND CC-DIAG-TRACE (NOT (ZEROP (LOGAND (LOGXOR ACTUAL DATA) MASK))))
351                  (FORMAT T "~&Reg address ~O, wrote ~O, read ~O" REGADR DATA ACTUAL)))
352           ACTUAL))
353        (T (FUNCALL (CAR REGADR) 'WRITE-READ DATA))))
354
355
356(DECLARE (SPECIAL CC-SUSPECT-BIT-LIST))
357
358;RETURNS T IF IT WORKS, PRINTS MESSAGE AND RETURNS NIL IF IT IS BUSTED.
359(DEFUN CC-TEST-DATA-PATH (MESSAGE REGADR NBITS)
360  (LET ((CC-LOW-LEVEL-FLAG 'VERY)
361        (TEM) 
362        (CC-SUSPECT-BIT-LIST NIL)
363        (ZEROS 0)
364        (ONES (SUB1 (LOGDPB 1 (+ (LSH NBITS 6) 0001) 0))))
365    (COND ((= (SETQ TEM (CC-WRITE-AND-READ REGADR ZEROS ONES))
366              (CC-WRITE-AND-READ REGADR ONES ONES))
367           (CC-BARF-ABOUT-DATA-PATH MESSAGE REGADR)
368           (PRINC "Can't affect it, erroneous value is ")
369           (PRIN1 TEM)
370           (TERPRI)
371           NIL)
372          (T (LET ((BITS-NOT-ONE (CC-TEST-DATA-PATH-FLOATING-BITS REGADR NBITS ZEROS))
373                   (BITS-NOT-ZERO (CC-TEST-DATA-PATH-FLOATING-BITS REGADR NBITS ONES)))
374               (COND ((AND (NULL BITS-NOT-ONE) (NULL BITS-NOT-ZERO)     ;NO ERROR
375                           (NULL CC-SUSPECT-BIT-LIST))
376                      T)
377                     (T
378                      (LET ((ERRONEOUS-BITS     ;BITS THAT LOSE, TEST FOR SHORTING
379                                (NUMERIC-LIST-UNION BITS-NOT-ONE BITS-NOT-ZERO)))
380                        (LET ((STUCK-AT-ZERO
381                                (NUMERIC-LIST-DIFFERENCE BITS-NOT-ONE BITS-NOT-ZERO))
382                              (STUCK-AT-ONE
383                                (NUMERIC-LIST-DIFFERENCE BITS-NOT-ZERO BITS-NOT-ONE)))
384                          (CC-BARF-ABOUT-DATA-PATH MESSAGE REGADR)
385                          (CC-PRINT-BIT-LIST "Bits stuck at zero: " STUCK-AT-ZERO)
386                          (CC-PRINT-BIT-LIST "Bits stuck at one: " STUCK-AT-ONE)
387                          (AND (= (LENGTH ERRONEOUS-BITS) 2)  ;MAYBE THEY'RE SHORTED TOGETHER
388                               (CC-TEST-DATA-PATH-SHORTED-BIT REGADR NBITS
389                                                              (CAR ERRONEOUS-BITS)))
390                          NIL)
391                        (CC-PRINT-BIT-LIST "The following bits are also suspected of being losers:"
392                                           CC-SUSPECT-BIT-LIST)
393
394))))))))
395
396;RETURN LIST OF BIT NUMBERS WHICH WON'T SET DIFFERENT FROM THE OTHERS.
397;ALSO SETS CC-SUSPECT-BIT-LIST TO BITS WHICH ARE NOTICED TO
398;BE LOSING WHILE TESTING DIFFERENT BITS.
399;NOTE THE NEED TO DO BIGNUM ARITHMETIC.
400
401(DEFUN CC-TEST-DATA-PATH-FLOATING-BITS (REGADR NBITS BACKGROUND)
402  ;FIRST, DETERMINE SENSE OF BIT LOOKING FOR
403  (LET ((BACK-BIT (COND ((ZEROP BACKGROUND) 0) (T 1)))
404        (SET-BIT (COND ((ZEROP BACKGROUND) 1) (T 0)))
405        (MASK (1- (LOGDPB 1 (+ (LSH NBITS 6) 0001) 0))))
406    (DO ((BITNO 0 (1+ BITNO))
407         (BITPOS 0001 (+ BITPOS 0100))
408         (READBACK)
409         (ERROR-LIST NIL))
410        ((>= BITNO NBITS) ERROR-LIST)
411      (SETQ READBACK (CC-WRITE-AND-READ REGADR (LOGDPB SET-BIT BITPOS BACKGROUND) MASK))
412      (DO ((I 0 (1+ I))
413           (PPSS 0001 (+ PPSS 0100))
414           (BIT))
415          ((>= I NBITS))
416        (SETQ BIT (LOGLDB PPSS READBACK))
417        (COND ((= I BITNO)
418               (OR (= SET-BIT BIT)
419                   (PUSH I ERROR-LIST)))
420              (T (OR (= BACK-BIT BIT)
421                     (CC-FINGER-SUSPECT-BIT I))))))))
422
423(DEFUN CC-FINGER-SUSPECT-BIT (BITNO)
424  (OR (NUMERIC-LIST-MEMQ BITNO CC-SUSPECT-BIT-LIST)
425      (SETQ CC-SUSPECT-BIT-LIST (CONS BITNO CC-SUSPECT-BIT-LIST))))
426
427;GIVEN A BIT WHICH FAILS, TRY TO PROVE IT IS SHORTED TO SOME OTHER BIT.
428;PRINT OUT THE RESULTS AND OUGHT TO REMOVE FROM SUSPECT LIST.                   *******
429;NOTE THAT FOR NON-COMPLEMENTED TRI-STATE DATA PATHS, 1 SHORTED TO 0 GIVES 0,
430;THUS IN THE NORMAL TEST SHORTED BITS LOOK STUCK AT ZERO.
431;THIS ONLY TESTS WITH ONES.
432(DEFUN CC-TEST-DATA-PATH-SHORTED-BIT (REGADR NBITS BITNO)
433  (DO ((BAD-BIT (LOGDPB 1 (+ (LSH BITNO 6) 0001) 0))
434       (I 0 (1+ I))
435       (TEST-BIT 0001 (+ TEST-BIT 100))
436       (BASE 10.)
437       (*NOPOINT T)
438       (LOSING-BITS NIL))
439      ((>= I NBITS)
440       (COND ((= (LENGTH LOSING-BITS) 1)
441              (NUMERIC-LIST-DELQ (CAR LOSING-BITS) CC-SUSPECT-BIT-LIST)
442              (PRINC "Bit ") (PRIN1 BITNO) (PRINC " is shorted to bit ")
443              (PRIN1 (CAR LOSING-BITS)) (TERPRI))
444             (T
445              (PRINC "Bit ") (PRIN1 BITNO) (PRINC " has problems, can't isolate.")
446              (TERPRI)
447              (CC-PRINT-BIT-LIST "Seems as if shorted to bits " LOSING-BITS))))
448    (LET ((BOTH-BITS (LOGDPB 1 TEST-BIT BAD-BIT)))
449      (COND ((= I BITNO))           ;OF COURSE IT'S SHORTED TO ITSELF!
450            ((= BOTH-BITS (CC-WRITE-AND-READ REGADR BOTH-BITS))
451             (PUSH I LOSING-BITS))))))
452
453(DEFUN CC-BARF-ABOUT-DATA-PATH (MESSAGE REGADR)
454  (TERPRI)
455  (PRINC "Testing register address ")
456  (PRIN1 REGADR)
457  (PRINC ",")
458  (TERPRI)
459  (PRINC " data path is ")
460  (PRINC MESSAGE)
461  (TERPRI))
462
463(DEFUN CC-PRINT-BITS (WD)
464  (LET ((CC-SUSPECT-BIT-LIST NIL))  ;KLUDGE
465    (CC-PRINT-BIT-LIST NIL (CC-WRONG-BITS-LIST 0 WD (HAULONG WD)))))
466
467(DEFUN CC-PRINT-BIT-LIST (MESSAGE BITLIST)
468  (COND (BITLIST
469         (COND (MESSAGE (PRINC MESSAGE)))
470         (DO ((L (SORT BITLIST 'LESSP) (CDR L))
471              (COMMA NIL T)
472              (LASTVALUE -2 (CAR L))
473              (RANGE-END NIL)
474              (RANGE-START)
475              (BASE 10.)
476              (*NOPOINT T))
477             ((NULL L)
478              (AND RANGE-END
479                   (COND ((= (1+ RANGE-START) RANGE-END)
480                          (PRINC ", ") (PRIN1 RANGE-END))
481                         (T (PRINC "-") (PRIN1 RANGE-END)))))
482           (COND ((= (CAR L) (1+ LASTVALUE))
483                  (OR RANGE-END (SETQ RANGE-START LASTVALUE))
484                  (SETQ RANGE-END (CAR L)))
485                 (T
486                  (AND RANGE-END
487                       (COND ((= (1+ RANGE-START) RANGE-END)
488                              (PRINC ", ") (PRIN1 RANGE-END))
489                             (T (PRINC "-") (PRIN1 RANGE-END))))
490                  (SETQ RANGE-END NIL)
491                  (AND COMMA (PRINC ", "))
492                  (PRIN1 (CAR L)))))
493         (SETQ CC-SUSPECT-BIT-LIST
494               (NUMERIC-LIST-DIFFERENCE CC-SUSPECT-BIT-LIST BITLIST))
495         (TERPRI))))
496
497;;; CADR ADDRESS TESTS THAT RUN IN THE MACHINE
498
499(DECLARE (SPECIAL CC-MODE-REG CC-DIAG-TRACE))
500
501(COMMENT TEST LOOP STORERS)
502
503;WRITE A-MEMORY, LC HAS ADDRESS SHIFTED INTO DESTINATION FIELD,
504;VMA IS ADDED TO LC EACH TIME AROUND THE LOOP, STOP VIA THE STATISTICS COUNTER,
505;MD HAS VALUE TO BE STORED, Q-R GETS ADDED TO MD EACH TIME AROUND THE LOOP.
506;TO DO THE ADDITIONS WE NEED SOMETHING IN A-MEM.  WE CAUSE IT TO COME
507;IN FROM THE PASS-AROUND PATH SO AS NOT TO TRUST THE MEMORY!
508;0:     ((OA-REG-LOW) LC)
509;1:     ((A-MEM) MD STAT-BIT) ;HALT HERE WHEN DONE
510;2:     ((1777@A) Q-R)
511;3:     ((MD) ADD MD 1777@A)
512;4:     ((1777@A) VMA)
513;5:     ((LC) ADD LC 1777@A)
514;6:     (JUMP 0)
515
516;THIS VERSION FILLS IT ALL ALTHOUGH IT COULD HAVE MORE PARAMETERS
517;BASHES 0@M AS USUAL
518;WRONG VALUE IN 0@A BECAUSE THE CODE BASHES 0@M AS IT RUNS AND A=M
519(DEFUN CC-FILL-A-MEM (VALUE VALUE-INC UPWARDS-P)
520  (CC-EXECUTE (W-C-MEM 0)
521        CONS-IR-M-SRC CONS-M-SRC-LC
522        CONS-IR-OB CONS-OB-ALU
523        CONS-IR-ALUF CONS-ALU-SETM
524        CONS-IR-FUNC-DEST CONS-FUNC-DEST-OA-LOW)
525  (CC-EXECUTE (W-C-MEM 1)
526        CONS-IR-STAT-BIT 1
527        CONS-IR-M-SRC CONS-M-SRC-MD
528        CONS-IR-OB CONS-OB-ALU
529        CONS-IR-ALUF CONS-ALU-SETM
530        CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-INDICATOR)
531  (CC-EXECUTE (W-C-MEM 2)
532        CONS-IR-M-SRC CONS-M-SRC-Q
533        CONS-IR-OB CONS-OB-ALU
534        CONS-IR-ALUF CONS-ALU-SETM
535        CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-1777)
536  (CC-EXECUTE (W-C-MEM 3)
537        CONS-IR-M-SRC CONS-M-SRC-MD
538        CONS-IR-A-SRC 1777
539        CONS-IR-OB CONS-OB-ALU
540        CONS-IR-ALUF CONS-ALU-ADD
541        CONS-IR-FUNC-DEST CONS-FUNC-DEST-MD)
542  (CC-EXECUTE (W-C-MEM 4)
543        CONS-IR-M-SRC CONS-M-SRC-VMA
544        CONS-IR-OB CONS-OB-ALU
545        CONS-IR-ALUF CONS-ALU-SETM
546        CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-1777)
547  (CC-EXECUTE (W-C-MEM 5)
548        CONS-IR-M-SRC CONS-M-SRC-LC
549        CONS-IR-A-SRC 1777
550        CONS-IR-OB CONS-OB-ALU
551        CONS-IR-ALUF CONS-ALU-ADD
552        CONS-IR-FUNC-DEST CONS-FUNC-DEST-LC)
553  (CC-EXECUTE (W-C-MEM 6)
554        CONS-IR-OP CONS-OP-JUMP
555        CONS-IR-JUMP-ADDR 0
556        CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
557        CONS-IR-N 1)
558  (CC-EXECUTE (W-C-MEM 7)       ;SO HAS GOOD PARITY
559        CONS-IR-OP CONS-OP-JUMP)
560  (CC-WRITE-STAT-COUNTER -1024.) ;STOP AFTER WRITING 1024. LOCATIONS
561  (COND (UPWARDS-P
562         (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC 0)       ;FIRST ADDRESS, SHIFTED OVER
563         (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA 1_14.)  ;ADDRESS INCREMENT (MAGIC NUMBER)
564         (CC-WRITE-Q VALUE-INC)
565         (CC-WRITE-MD VALUE))
566        (T
567         (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC 1777_14.);FIRST ADDRESS, SHIFTED OVER
568         (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA -1_14.) ;ADDRESS INCREMENT (MAGIC NUMBER)
569         (CC-WRITE-Q (- VALUE-INC))
570         (CC-WRITE-MD (+ VALUE (* 2000 VALUE-INC)))))
571  (CC-RUN-TEST-LOOP 0))
572
573(DECLARE (SPECIAL SPY-MODE SPY-CLK SPY-FLAG-1) (FIXNUM (SPY-READ FIXNUM)))
574
575(DEFUN CC-RUN-TEST-LOOP (ADR)
576  (CC-WRITE-PC ADR)
577  (CC-NOOP-CLOCK)               ;FIRST INSTRUCTION TO IR
578  (CC-CLOCK)                    ;CLOCK AGAIN
579  (SPY-WRITE SPY-MODE (LOGIOR CC-MODE-REG 10))  ;ENABLE STAT HALT
580  (SPY-WRITE SPY-CLK 1) ;TAKE OFF
581  (DO () ((ZEROP (BOOLE 1 4000 (SPY-READ SPY-FLAG-1))))
582    #M (SLEEP 1)
583    #Q (COND ((KBD-TYI-NO-HANG) (BREAK CC-RUN-TEST-LOOP))
584             (T (PROCESS-SLEEP 15.))))         ;AWAIT STAT HALT
585  )
586
587
588;SCAN A-MEMORY, LC HAS ADDRESS SHIFTED INTO SOURCE FIELD,
589;VMA IS ADDED TO LC EACH TIME AROUND THE LOOP, STOP VIA THE STATISTICS COUNTER,
590;MD HAS VALUE TO BE CHECKED FOR, Q-R GETS ADDED TO MD EACH TIME AROUND THE LOOP.
591;TO DO THE ADDITIONS WE NEED SOMETHING IN A-MEM.  WE CAUSE IT TO COME
592;IN FROM THE PASS-AROUND PATH SO AS NOT TO TRUST THE MEMORY!
593;WE BASH 0@A SINCE IT LOSES ANYWAY.
594;HALT BY GOING INTO A LOOP WITH STAT-BIT ON IF COMPARE FAILS, GOOD DATA IN MD,
595;BAD DATA IN 0@M.
596;0:     ((OA-REG-HIGH) LC)
597;1:     ((0@M) 0@A STAT-BIT) ;HALT HERE WHEN DONE, C(A) TO 0@A, 0@M, L
598;2:     (JUMP-NOT-EQUAL MD 0@A 10)
599;3:     ((0@A) Q-R)
600;4:     ((MD) ADD MD 0@A)
601;5:     ((0@A) VMA)
602;6:     ((LC) ADD LC 0@A)
603;7:     (JUMP 0)
604;10:    (JUMP 10 STAT-BIT)      ;HALT HERE IF ERROR
605
606;SCAN OUT A-MEMORY FROM 2@A THROUGH 1777@A, RETURN A LIST OF MISMATCHES
607;IN THE FORM ((ADDR GOOD BAD) ...)
608;BASHES 0@M AS USUAL.  0@A IS KNOWN TO BE BAD.
609;WRITING INTO CONTROL MEMORY BASHES 1@A, SO WE DON'T SCAN THAT EITHER.
610(DEFUN CC-SCAN-A-MEM (VALUE VALUE-INC)
611  (CC-EXECUTE (W-C-MEM 0)
612        CONS-IR-M-SRC CONS-M-SRC-LC
613        CONS-IR-OB CONS-OB-ALU
614        CONS-IR-ALUF CONS-ALU-SETM
615        CONS-IR-FUNC-DEST CONS-FUNC-DEST-OA-HIGH)
616  (CC-EXECUTE (W-C-MEM 1)
617        CONS-IR-STAT-BIT 1
618        CONS-IR-A-SRC 0
619        CONS-IR-OB CONS-OB-ALU
620        CONS-IR-ALUF CONS-ALU-SETA
621        CONS-IR-M-MEM-DEST 0)
622  (CC-EXECUTE (W-C-MEM 2)
623        CONS-IR-OP CONS-OP-JUMP
624        CONS-IR-M-SRC CONS-M-SRC-MD
625        CONS-IR-A-SRC 0
626        CONS-IR-JUMP-ADDR 10
627        CONS-IR-JUMP-COND CONS-JUMP-COND-M-NEQ-A
628        CONS-IR-N 1)
629  (CC-EXECUTE (W-C-MEM 3)
630        CONS-IR-M-SRC CONS-M-SRC-Q
631        CONS-IR-OB CONS-OB-ALU
632        CONS-IR-ALUF CONS-ALU-SETM
633        CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-INDICATOR)
634  (CC-EXECUTE (W-C-MEM 4)
635        CONS-IR-M-SRC CONS-M-SRC-MD
636        CONS-IR-A-SRC 0
637        CONS-IR-OB CONS-OB-ALU
638        CONS-IR-ALUF CONS-ALU-ADD
639        CONS-IR-FUNC-DEST CONS-FUNC-DEST-MD)
640  (CC-EXECUTE (W-C-MEM 5)
641        CONS-IR-M-SRC CONS-M-SRC-VMA
642        CONS-IR-OB CONS-OB-ALU
643        CONS-IR-ALUF CONS-ALU-SETM
644        CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-INDICATOR)
645  (CC-EXECUTE (W-C-MEM 6)
646        CONS-IR-M-SRC CONS-M-SRC-LC
647        CONS-IR-A-SRC 0
648        CONS-IR-OB CONS-OB-ALU
649        CONS-IR-ALUF CONS-ALU-ADD
650        CONS-IR-FUNC-DEST CONS-FUNC-DEST-LC)
651  (CC-EXECUTE (W-C-MEM 7)
652        CONS-IR-OP CONS-OP-JUMP
653        CONS-IR-JUMP-ADDR 0
654        CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
655        CONS-IR-N 1)
656  (CC-EXECUTE (W-C-MEM 10)
657        CONS-IR-OP CONS-OP-JUMP
658        CONS-IR-JUMP-ADDR 10
659        CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
660        CONS-IR-N 1
661        CONS-IR-STAT-BIT 1)
662  (DO ((ADDRESS 2)      ;LOOP REPEATS EACH TIME MACHINE HALTS
663       (LOC) (GOOD) (BAD)
664       (ERRORS NIL))
665      (())
666    (DECLARE (FIXNUM ADDRESS))
667    (CC-WRITE-STAT-COUNTER (- ADDRESS 1024.))   ;NUMBER OF LOCATIONS YET TO SCAN
668    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC (LSH ADDRESS 6))      ;FIRST ADDRESS, SHIFTED OVER
669    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA 1_6) ;ADDRESS INCREMENT (MAGIC NUMBER)
670    (CC-WRITE-Q VALUE-INC)
671    (CC-WRITE-MD (+ VALUE (* VALUE-INC ADDRESS)))
672    (CC-RUN-TEST-LOOP 0)                        ;RUN UNTIL DONE OR ERROR
673    (AND (= (CC-READ-PC) 3)                     ;NORMAL HALT, DONE
674         (RETURN (NREVERSE ERRORS)))
675    (SETQ ADDRESS (1+ (#Q ASH #M LSH (CC-READ-M-MEM CONS-M-SRC-LC) -6))  ;NEXT ADDRESS TO DO
676          LOC (1- ADDRESS)
677          GOOD (CC-READ-M-MEM CONS-M-SRC-MD)
678          BAD (CC-READ-M-MEM 0))
679    (AND CC-DIAG-TRACE (PRINT (LIST 'LOC LOC 'GOOD GOOD 'BAD BAD)))
680    (SETQ ERRORS (CONS (LIST LOC GOOD BAD) ERRORS))))
681
682(DEFUN CC-ADDRESS-TEST-A-MEM ()
683  (DO ((SHIFT 0 (1+ SHIFT))
684       (ADDEND (+ 1 (LSH 1 10.) (LSH 1 20.) (LSH 1 30.))
685               (+ ADDEND ADDEND))
686       (TEM))
687      ((= SHIFT 10.))
688    (DECLARE (FIXNUM SHIFT ADDEND))
689    (CC-FILL-A-MEM 0 ADDEND T)                  ;FILL UPWARDS WITH ADDRESS
690    (COND ((SETQ TEM (CC-SCAN-A-MEM 0 ADDEND))  ;SCAN FOR ERRORS
691           (CC-FILL-A-MEM 0 ADDEND NIL)         ;GOT ERROR, FILL DOWNWARDS
692           (CC-ADDRESS-TEST-ANALYZE TEM (CC-SCAN-A-MEM 0 ADDEND) SHIFT NIL))) ;TELL RESULTS
693    (CC-FILL-A-MEM -1 (- ADDEND) T)             ;FILL UPWARDS WITH COMPLEMENT OF ADDRESS
694    (COND ((SETQ TEM (CC-SCAN-A-MEM -1 (- ADDEND)))     ;SCAN FOR ERRORS
695           (CC-FILL-A-MEM -1 (- ADDEND) NIL)    ;GOT ERROR, FILL DOWNWARDS
696           (CC-ADDRESS-TEST-ANALYZE TEM (CC-SCAN-A-MEM -1 (- ADDEND))
697                                    SHIFT T)))))        ;TELL RESULTS
698
699;THIS COULD BE MUCH HAIRIER
700(DEFUN CC-ADDRESS-TEST-ANALYZE (UPWARD-ERRORS DOWNWARD-ERRORS SHIFT COMPLEMENT-P)
701  SHIFT COMPLEMENT-P
702  (DO ((L (NCONC UPWARD-ERRORS DOWNWARD-ERRORS) (CDR L))
703       (ADDRESS-AND -1)
704       (ADDRESS-IOR 0)
705       (DATA-BITS-IN-ERROR 0))
706      ((NULL L)
707       (PRINC "Address AND ") (PRIN1 ADDRESS-AND)
708       (PRINC ", address IOR ") (PRIN1 ADDRESS-IOR)
709       (PRINC ", data bits in error ") (PRIN1 DATA-BITS-IN-ERROR)
710       (TERPRI))
711    (DECLARE (FIXNUM ADDRESS-AND ADDRESS-IOR DATA-BITS-IN-ERROR)) ;NOT TESTING C-MEM
712    (SETQ ADDRESS-AND (LOGAND (CAAR L) ADDRESS-AND)
713          ADDRESS-IOR (LOGIOR (CAAR L) ADDRESS-IOR)
714          DATA-BITS-IN-ERROR (LOGIOR (LOGXOR (CADAR L) (CADDAR L)) DATA-BITS-IN-ERROR))))
715
716;Fast address test writes zeros and ones into 2 locations
717;whose addresses differ in 1 bit, checks for interference.
718;This detects address bits stuck at zero or one for some data
719;bits, but does not detect adjacent address bits shorted together.
720(DEFUN CC-FAST-ADDRESS-TEST (MEM-NAME REGADR N-DATA-BITS N-ADDRESS-BITS)
721  (DECLARE (FIXNUM REGADR N-DATA-BITS N-ADDRESS-BITS))
722  (DO ((N (COND ((EQ MEM-NAME 'C-MEM) 2)  ;C-MEM MAY NOT BE A POWER OF 2. CROCK.
723                (T 4))
724          (1- N))
725       (PHASE 0 (1+ PHASE))
726       (ONES (SUB1 (EXPT 2 N-DATA-BITS)))
727       (ADR-MASK (1- (EXPT 2 N-ADDRESS-BITS)))
728       (ZEROS 0))
729      ((= N 0))
730    (DO ((BITNO 0 (1+ BITNO))
731         (GOOD1 (COND ((EVENP PHASE) ZEROS) (T ONES)))
732         (GOOD2 (COND ((EVENP PHASE) ONES) (T ZEROS)))
733         (BAD1)
734         (BAD2)
735         (BAD3)
736         (OTHER-LOC)
737         (K)
738         (CC-SUSPECT-BIT-LIST))
739        ((= BITNO N-ADDRESS-BITS))
740      (SETQ K (+ REGADR (COND ((< PHASE 2)
741                               (LSH 1 BITNO))
742                              (T (LOGXOR ADR-MASK (LSH 1 BITNO))))))
743      (SETQ OTHER-LOC (COND ((< PHASE 2) REGADR)
744                            (T (+ REGADR ADR-MASK))))
745      (CC-R-D K GOOD2)
746      (COND ((NOT (EQUAL (SETQ BAD2 (CC-R-E K)) GOOD2))
747             (PRINC MEM-NAME) (PRINC " loc ") (PRIN1 (- K REGADR))
748             (CC-PRINT-BIT-LIST " fails in data bits "
749                                (CC-WRONG-BITS-LIST GOOD2 BAD2 N-DATA-BITS))))
750      (CC-R-D OTHER-LOC GOOD1)                  ;Deposit in loc 0 second for A & M's sake
751      (COND ((NOT (EQUAL (SETQ BAD1 (CC-R-E OTHER-LOC)) GOOD1))
752             (PRINC MEM-NAME) (FORMAT T " LOC ~O" (- OTHER-LOC REGADR))
753             (CC-PRINT-BIT-LIST " fails in data bits "
754                                (CC-WRONG-BITS-LIST GOOD1 BAD1 N-DATA-BITS))))
755      (COND ((NOT (EQUAL (SETQ BAD3 (CC-R-E K)) GOOD2))
756             (FORMAT T "~A address bit ~D (~O and ~O)"
757                     MEM-NAME BITNO (- K REGADR) (- OTHER-LOC REGADR))
758             (CC-PRINT-BIT-LIST (COND ((EVENP PHASE)
759                                       " fails storing 1's then 0 in data bits ")
760                                      (T " fails storing 0 then 1's in data bits "))
761                                (CC-WRONG-BITS-LIST GOOD2 BAD3 N-DATA-BITS)))))))
762
763(DEFUN CC-QUIET-ADDRESS-TEST (MEM-NAME REGADR N-DATA-BITS N-ADDRESS-BITS)
764  (DECLARE (FIXNUM REGADR N-DATA-BITS N-ADDRESS-BITS))
765  (DO ((N (COND ((EQ MEM-NAME 'C-MEM) 2)  ;C-MEM MAY NOT BE A POWER OF 2. CROCK.
766                (T 4))
767          (1- N))
768       (PHASE 0 (1+ PHASE))
769       (ONES (SUB1 (EXPT 2 N-DATA-BITS)))
770       (ADR-MASK (1- (EXPT 2 N-ADDRESS-BITS)))
771       (ZEROS 0))
772      ((= N 0))
773    (DO ((BITNO 0 (1+ BITNO))
774         (GOOD (COND ((EVENP PHASE) ONES) (T ZEROS)))
775         (OTHER-LOC)
776         (K)
777         (CC-SUSPECT-BIT-LIST))
778        ((= BITNO N-ADDRESS-BITS))
779      (SETQ K (+ REGADR (COND ((< PHASE 2)
780                               (LSH 1 BITNO))
781                              (T (LOGXOR ADR-MASK (LSH 1 BITNO))))))
782      (SETQ OTHER-LOC (COND ((< PHASE 2) REGADR)
783                            (T (+ REGADR ADR-MASK))))
784      (CC-R-D K GOOD))))
785
786;Test all bits of memory for ability to retain 0's, 1's. Then try 0's in
787; even addresses, 1's in odd ones.
788(DEFUN CC-GROSS-DATA-TEST (MEM-NAME REGADR N-DATA-BITS N-ADDRESS-BITS
789                          &OPTIONAL (MAX-ERRORS 5.) &AUX CC-SUSPECT-BIT-LIST)
790 (*CATCH 'EXIT
791  (DO ((N 3 (1- N))
792       (ONES (SUB1 (EXPT 2 N-DATA-BITS)))
793       (ZEROS 0)
794       (HIADR (+ REGADR (COND ((EQ MEM-NAME 'C-MEM) 30000)   ;CROCK
795                              (T (EXPT 2 N-ADDRESS-BITS)))))
796       (ERRORS 0))
797      ((= N 0))
798    (DO ((ADR REGADR (+ ADR 2))
799         (EVEN-DATA (COND ((= N 2) ZEROS)
800                          ((= N 1) ONES)
801                          (T ZEROS)))
802         (ODD-DATA (COND ((= N 2) ZEROS)
803                         ((= N 1) ONES)
804                         (T ONES))))
805        ((>= ADR HIADR)
806         (DO ((ADR REGADR (+ ADR 2))
807              (TEM))
808             ((>= ADR HIADR))
809           (COND ((NOT (= (SETQ TEM (CC-R-E ADR)) EVEN-DATA))
810                  (FORMAT T "~%Wrote ~S in locn ~S of ~S, read ~S losing bits "
811                          EVEN-DATA (- ADR REGADR) MEM-NAME TEM)
812                  (CC-PRINT-BIT-LIST NIL (CC-WRONG-BITS-LIST EVEN-DATA TEM N-DATA-BITS))
813                  (COND ((> (SETQ ERRORS (1+ ERRORS)) MAX-ERRORS)
814                         (*THROW 'EXIT NIL)))))
815           (COND ((NOT (= (SETQ TEM (CC-R-E (1+ ADR))) ODD-DATA))
816                  (FORMAT T "~%Wrote ~S in locn ~S of ~S, read ~S losing bits"
817                          ODD-DATA (1+ (- ADR REGADR)) MEM-NAME TEM)
818                  (CC-PRINT-BIT-LIST NIL (CC-WRONG-BITS-LIST ODD-DATA TEM N-DATA-BITS))
819                  (COND ((> (SETQ ERRORS (1+ ERRORS)) MAX-ERRORS)
820                         (*THROW 'EXIT NIL)))))))
821      (CC-R-D ADR EVEN-DATA)
822      (CC-R-D (1+ ADR) ODD-DATA)))))
823
824(DEFUN PRIN1-DECIMAL (X)
825  (LET ((BASE 10.) (*NOPOINT T))
826    (PRIN1 X)))
827
828(DEFUN CC-WRONG-BITS-LIST (GOOD BAD N-DATA-BITS)
829  (DO ((BITNO 0 (1+ BITNO))
830       (PPSS 0001 (+ 100 PPSS))
831       (L NIL))
832      ((= BITNO N-DATA-BITS) L)
833    (OR (= (LOGLDB PPSS GOOD) (LOGLDB PPSS BAD))
834        (SETQ L (CONS BITNO L)))))
835
836(DEFUN CC-TEST-SPC-POINTER ()
837  (PROG (USP READ GOOD)
838        (PRINT 'CC-TEST-SPC-POINTER)
839        (SETQ USP (CC-READ-MICRO-STACK-PTR))
840        (DOTIMES (C 32.)
841          (CC-EXECUTE (WRITE)
842                      CONS-IR-M-SRC CONS-M-SRC-MD       ;PUSH IT
843                      CONS-IR-ALUF CONS-ALU-SETM
844                      CONS-IR-OB CONS-OB-ALU
845                      CONS-IR-FUNC-DEST CONS-FUNC-DEST-MICRO-STACK-PUSH)
846          (SETQ READ (CC-READ-MICRO-STACK-PTR))
847          (COND ((NOT (= (SETQ GOOD (LOGAND 37 (+ (1+ C) USP))) READ))
848                 (FORMAT T "~%SPC PTR INCREMENT FAILED, WAS ~S, SHOULD BE ~S" READ GOOD))))
849        (SETQ USP (CC-READ-MICRO-STACK-PTR))
850        (DOTIMES (C 32.)
851           (CC-EXECUTE (WRITE)
852                       CONS-IR-M-SRC CONS-M-SRC-MICRO-STACK-POP
853                       CONS-IR-ALUF CONS-ALU-SETM
854                       CONS-IR-OB CONS-OB-ALU)
855           (SETQ READ (CC-READ-MICRO-STACK-PTR))
856           (COND ((NOT (= (SETQ GOOD (LOGAND 37 (- USP (1+ C)))) READ))
857                  (FORMAT T "~%SPC PTR DECREMENT FAILED, WAS ~S, SHOULD BE ~S" READ GOOD))))
858        ))
859
860(DEFUN CC-WRITE-ZERO-SPC (&OPTIONAL (V 0))
861  (DO ()((KBD-TYI-NO-HANG))
862    (CC-WRITE-MD V)     ;GET DATA INTO MRD
863    (CC-EXECUTE (WRITE)
864                CONS-IR-M-SRC CONS-M-SRC-MD     ;PUSH IT
865                CONS-IR-ALUF CONS-ALU-SETM
866                CONS-IR-OB CONS-OB-ALU
867                CONS-IR-FUNC-DEST CONS-FUNC-DEST-MICRO-STACK-PUSH)))
868
869
870
871
872
873;;; CADR SHIFTER TEST                                           -*-LISP-*-
874
875(DECLARE (FIXNUM SPY-IR-LOW (SPY-READ FIXNUM))
876         (NOTYPE (SPY-WRITE FIXNUM FIXNUM))
877         (SPECIAL SPY-IR-LOW)
878         (*EXPR SPY-READ SPY-WRITE))
879
880(DEFUN CC-TEST-SPY-IR ()
881  (DOLIST (PART '(SPY-IR-HIGH SPY-IR-MED SPY-IR-LOW))
882    (DOLIST (BACKGROUND '(0 177777))
883      (DO ((I 0 (1+ I))
884           (BIT 1 (ASH BIT 1)))
885          (( I 16.))
886        (LET ((PATTERN (LOGXOR BIT BACKGROUND)))
887          (SPY-WRITE (SYMEVAL PART) PATTERN)
888          (CC-NOOP-DEBUG-CLOCK)
889          (LET ((ACTUAL (SPY-READ (SYMEVAL PART))))
890            (OR (= ACTUAL PATTERN)
891                (FORMAT T "~&SPY-IR - Wrote: ~O, Read: ~O" PATTERN ACTUAL))))))))
892
893(DEFMACRO ADD2L (ITEM LIST)
894  `(OR (NUMERIC-LIST-MEMQ ,ITEM ,LIST)
895       (SETQ ,LIST (CONS ,ITEM ,LIST))))
896
897
898;; Algorithm is to shift floating ones and zeros with all possible shifts.
899;; Record bits that failed at shifter input, at shifter output, between
900;; the two shifter stages, and also which shift counts fail.  Note that
901;; if the masker proms aren't plugged in, selecting the 32-bit-wide byte
902;; will work anyway due to pullups.  Prom problems will show up as failure
903;; of particular bits at the shifter output, you can try unplugging the
904;; offending prom.  To reduce randomness we bring 0 in
905;; on the A-source.  This is now written so that it works whether or
906;; not proms are present, it addresses 0 in the right mask which is all 1's
907;; and 37 in the left mask which is also all 1's.
908(DECLARE (SPECIAL CC-SUSPECT-BIT-LIST))
909(DEFUN CC-TEST-SHIFTER ()
910  (CC-WRITE-A-MEM 2 0)
911  (DO ((INPUT-ERRONEOUS-ZEROS NIL)
912       (MIDDLE-ERRONEOUS-ZEROS NIL)
913       (OUTPUT-ERRONEOUS-ZEROS NIL)
914       (INPUT-ERRONEOUS-ONES NIL)
915       (MIDDLE-ERRONEOUS-ONES NIL)
916       (OUTPUT-ERRONEOUS-ONES NIL)
917       (ERRONEOUS-SHIFT-COUNTS NIL)
918       (CC-SUSPECT-BIT-LIST NIL)
919       (BITNO 0 (1+ BITNO))) ;THE FLOATING BIT
920      ((= BITNO 32.)
921       (TERPRI)
922       (CC-PRINT-BIT-LIST "Shift counts with erroneous bits: " ERRONEOUS-SHIFT-COUNTS)
923       (CC-PRINT-BIT-LIST "M bits with erroneous zeros: " INPUT-ERRONEOUS-ZEROS)
924       (CC-PRINT-BIT-LIST "SA bits with erroneous zeros: " MIDDLE-ERRONEOUS-ZEROS)
925       (CC-PRINT-BIT-LIST "R bits with erroneous zeros: " OUTPUT-ERRONEOUS-ZEROS)
926       (CC-PRINT-BIT-LIST "M bits with erroneous ones: " INPUT-ERRONEOUS-ONES)
927       (CC-PRINT-BIT-LIST "SA bits with erroneous ones: " MIDDLE-ERRONEOUS-ONES)
928       (CC-PRINT-BIT-LIST "R bits with erroneous ones: " OUTPUT-ERRONEOUS-ONES))
929    (DO ((BACKGROUND 37777777777 0))  ;FIRST FLOATING ZEROS, THEN FLOATING ONES
930        (())
931      (DECLARE (FIXNUM BACKGROUND))
932      (CC-WRITE-MD (LOGXOR BACKGROUND #M (LSH 1 BITNO) #Q (ASH 1 BITNO)))  ;SHIFTER INPUT
933      (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE       ;INST TO SHIFT BY 0 INTO IR
934                  CONS-IR-A-SRC 2
935                  CONS-IR-M-SRC CONS-M-SRC-MD
936                  CONS-IR-BYTL-1 37
937                  CONS-IR-MROT 0
938                  CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-LDB) ;LDB = SR, NOT MR
939      (DO ((MROT 0 (1+ MROT))
940           (BAD)
941           (CORRECT-IR (SPY-READ SPY-IR-LOW) (1+ CORRECT-IR))
942           (GOOD (LOGXOR BACKGROUND #M (LSH 1 BITNO) #Q (ASH 1 BITNO)) ;EXPECTED OUTPUT
943                 (ROT32 GOOD 1)))
944          ((= MROT 32.))
945        (DECLARE (FIXNUM MROT GOOD BAD))
946        (COND ((NOT (= (SETQ BAD (CC-READ-OBUS)) GOOD)) ;HA! AN ERROR, STASH STUFF AWAY
947               (IF-FOR-LISPM
948                (COND (CC-DIAG-TRACE
949                       (FORMAT T "~&Rot: ~O, Bit: ~O, Good: ~O, Bad: ~O, Reread: ~O"
950                               MROT (ASH 1 BITNO) GOOD BAD (CC-READ-OBUS))) ))
951               (ADD2L MROT ERRONEOUS-SHIFT-COUNTS)
952               (DO ((J 0 (1+ J))                ;BITS OF OUTPUT
953                    (GOOD GOOD #M (LSH GOOD -1) #Q (ASH GOOD -1))
954                    (BAD BAD #M (LSH BAD -1) #Q (ASH BAD -1)))
955                   ((= J 32.))
956                 (OR (= (LOGAND 1 GOOD) (LOGAND 1 BAD))
957                     (COND ((ZEROP (LOGAND 1 GOOD))  ;AN ERRONEOUS ONE
958                            (ADD2L J OUTPUT-ERRONEOUS-ONES)
959                            (ADD2L (LOGAND (- J MROT) 37) INPUT-ERRONEOUS-ONES)
960                            (ADD2L (LOGAND (- J (LOGAND MROT -4)) 37) MIDDLE-ERRONEOUS-ONES))
961                           (T
962                            (ADD2L J OUTPUT-ERRONEOUS-ZEROS)
963                            (ADD2L (LOGAND (- J MROT) 37) INPUT-ERRONEOUS-ZEROS)
964                            (ADD2L (LOGAND (- J (LOGAND MROT -4)) 37) MIDDLE-ERRONEOUS-ZEROS)
965                            ))))))
966        (SPY-WRITE SPY-IR-LOW (1+ (SPY-READ SPY-IR-LOW)))       ;INCREMENT MROT FIELD
967        (CC-NOOP-DEBUG-CLOCK)
968        (LET ((ACTUAL-IR (SPY-READ SPY-IR-LOW)))        ;Did the IR get written correctly?
969          (COND ((NOT (= (1+ CORRECT-IR) ACTUAL-IR))
970                 (FORMAT T "~&Debug IR -  Correct: ~O, Read back: ~O"
971                         (1+ CORRECT-IR) ACTUAL-IR)))))
972      (AND (ZEROP BACKGROUND) (RETURN NIL)))))
973
974;; With the shift data paths known to work, read out all elements of the left
975;; mask and verify that they contain the correct contents.  We continue to
976;; select location 0 of the right mask, which is all 1's.
977;; It may be helpful to pull out the right-mask proms at this stage.
978(DEFUN CC-TEST-MASK-LEFT ()
979  (CC-WRITE-A-MEM 1 0)
980  (CC-WRITE-M-MEM 2 37777777777)
981  ((LAMBDA (TEM)
982      (DECLARE (FIXNUM TEM))
983      (SETQ TEM (CC-READ-A-MEM 1))
984      (OR (= 0 TEM)
985          (ERROR '|in 1@A - should be 0| TEM 'FAIL-ACT))
986      (SETQ TEM (CC-READ-M-MEM 2))
987      (OR (= 37777777777 TEM)
988          (ERROR '|in 2@M - should be 37777777777| TEM 'FAIL-ACT))
989      (DO ((BYTL-1 0 (1+ BYTL-1))
990           (GOOD 1 (1+ #M (LSH GOOD 1) #Q (ASH GOOD 1))))
991          ((= BYTL-1 32.))
992        (DECLARE (FIXNUM BYTL-1 GOOD))
993        (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE
994                    CONS-IR-A-SRC 1
995                    CONS-IR-M-SRC 2
996                    CONS-IR-BYTL-1 BYTL-1
997                    CONS-IR-MROT 0
998                    CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-LDB)  ;LDB = SR, NO MR
999        (SETQ TEM (CC-READ-OBUS))
1000        (COND ((NOT (= TEM GOOD))
1001               (PRINC '|/
1002BYTL-1=|)
1003               (PRIN1 BYTL-1)
1004               (PRINC '|, MROT=0, Left Mask=|)
1005               (PRIN1 TEM)
1006               (PRINC '|, should be |)
1007               (PRIN1 GOOD)))))
1008   0))
1009
1010;; With the shift data paths and the left mask known to work, read out
1011;; all locations of the right mask and verify that they are correct.
1012;; Here we hold the left mask at all 1's, which incidentally tests its
1013;; address adder.
1014(DEFUN CC-TEST-MASK-RIGHT ()
1015  (CC-WRITE-A-MEM 1 0)
1016  (CC-WRITE-M-MEM 2 37777777777)
1017  ((LAMBDA (TEM)
1018      (DECLARE (FIXNUM TEM))
1019      (SETQ TEM (CC-READ-A-MEM 1))
1020      (OR (= 0 TEM)
1021          (ERROR '|in 1@A - should be 0| TEM 'FAIL-ACT))
1022      (SETQ TEM (CC-READ-M-MEM 2))
1023      (OR (= 37777777777 TEM)
1024          (ERROR '|in 2@M - should be 37777777777| TEM 'FAIL-ACT))
1025      (DO ((MROT 0 (1+ MROT)) ;right mask address
1026           (BYTL-1 37 (1- BYTL-1)) ;keeps the left mask address = 37
1027           (GOOD 37777777777 (LOGXOR GOOD #M (LSH 1 MROT) #Q (ASH 1 MROT))))
1028          ((= MROT 32.))
1029        (DECLARE (FIXNUM MROT BYTL-1 GOOD))
1030        (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE
1031                    CONS-IR-A-SRC 1
1032                    CONS-IR-M-SRC 2
1033                    CONS-IR-BYTL-1 BYTL-1
1034                    CONS-IR-MROT MROT
1035                    CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-SELECTIVE-DEPOSIT)  ;MR, NO SR
1036        (SETQ TEM (CC-READ-OBUS))
1037        (COND ((NOT (= TEM GOOD))
1038               (PRINC '|/
1039BYTL-1=|)
1040               (PRIN1 BYTL-1)
1041               (PRINC '|, MROT=|)
1042               (PRIN1 MROT)
1043               (PRINC '|, Right Mask=|)
1044               (PRIN1 TEM)
1045               (PRINC '|, should be |)
1046               (PRIN1 GOOD)))))
1047   0))
1048
1049;; Verify that the masker works.  This finds things like broken wires on
1050;; the mask inputs to the 9S42's.
1051;; The somewhat simple-minded algorithm is to make the masker select all M
1052;; and make sure no bits from A get OR'ed in, then select all A and make sure
1053;; no bits from M get OR'ed in.
1054(DEFUN CC-TEST-MASKER ()
1055  (LET ((CC-SUSPECT-BIT-LIST NIL))
1056    (CC-WRITE-A-MEM 1 37777777777)
1057    (CC-WRITE-M-MEM 2 0)
1058    (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE
1059                CONS-IR-A-SRC 1
1060                CONS-IR-M-SRC 2
1061                CONS-IR-BYTL-1 37
1062                CONS-IR-MROT 0
1063                CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-SELECTIVE-DEPOSIT)
1064    (CC-PRINT-BIT-LIST "Erroneous A bits coming through masker:"
1065                       (CC-WRONG-BITS-LIST 0 (CC-READ-OBUS) 32.))
1066    (LET ((RH 0) (LH 0))
1067      (DECLARE (FIXNUM LH RH))
1068      (CC-WRITE-A-MEM 1 0)
1069      (CC-WRITE-M-MEM 2 37777777777)
1070      (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE       ;Select A in the right half
1071                  CONS-IR-A-SRC 1
1072                  CONS-IR-M-SRC 2
1073                  CONS-IR-BYTL-1 17
1074                  CONS-IR-MROT 20
1075                  CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-SELECTIVE-DEPOSIT)
1076      (SETQ RH (CC-READ-OBUS))
1077      (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE       ;Select A in the left half
1078                  CONS-IR-A-SRC 1
1079                  CONS-IR-M-SRC 2
1080                  CONS-IR-BYTL-1 17
1081                  CONS-IR-MROT 0
1082                  CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-SELECTIVE-DEPOSIT)
1083      (SETQ LH (CC-READ-OBUS))
1084      (CC-PRINT-BIT-LIST "Erroneous M bits coming through masker:"
1085                         (CC-WRONG-BITS-LIST 0 (DPB (LDB 2020 LH) 2020 RH) 32.)))))
1086
1087;; With the normal shift and mask logic known to work, test LC-modification.
1088;; Things to test are whether both halfwords and all 4 bytes properly mung
1089;; the MROT field.  Doesn't currently test whether automatic fetching.
1090;; Does test LC incrementing.  Eventually that should be tested.
1091(DEFUN CC-TEST-LC-AFFECTS-SHIFT ()
1092  (CC-WRITE-A-MEM 1 0)
1093  (CC-WRITE-M-MEM 2 37777777777)
1094  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-INT-CNTRL 1_29.) ;Put machine in byte mode
1095  (DO ((LC 1 (1+ LC))
1096       (LC-READBACK (+ 1_31. 1_29. 1) (1+ LC-READBACK)) ;Needfetch, Byte Mode, 1
1097       (GOOD 377 #M (LSH GOOD 8) #Q (ASH GOOD 8))
1098       (TEM))
1099      ((= LC 5))
1100    (DECLARE (FIXNUM LC LC-READBACK GOOD TEM))
1101    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC LC) ;Select byte (initially rightmost, LC=current+1)
1102    (SETQ TEM (CC-READ-M-MEM CONS-M-SRC-LC))
1103    (COND ((NOT (= TEM LC-READBACK))
1104           (PRINC '|/
1105Wrong value in LC, is |)
1106           (PRIN1 TEM)
1107           (PRINC '|, but should be |)
1108           (PRIN1 LC-READBACK)))
1109    (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE
1110                CONS-IR-A-SRC 1
1111                CONS-IR-M-SRC 2
1112                CONS-IR-BYTL-1 7
1113                CONS-IR-MROT 0
1114                CONS-IR-MF 3
1115                CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-SELECTIVE-DEPOSIT)  ;MR, NO SR
1116    (SETQ TEM (CC-READ-OBUS))
1117    (COND ((NOT (= TEM GOOD))
1118           (PRINC '|/
1119LC=|)
1120           (PRIN1 LC-READBACK)
1121           (PRINC '| (byte mode), shifter output=|)
1122           (PRIN1 TEM)
1123           (PRINC '|, should be |)
1124           (PRIN1 GOOD))))
1125  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-INT-CNTRL 0_29.) ;Put machine in word mode
1126  (DO ((LC 2 (+ LC 2))
1127       (LC-READBACK (+ 1_31. 2) (+ LC-READBACK 2)) ;Needfetch, no Byte Mode, 2 (=1 wd)
1128       (GOOD 177777 #M (LSH GOOD 16.) #Q (ASH GOOD 16.))
1129       (TEM))
1130      ((= LC 4))
1131    (DECLARE (FIXNUM LC LC-READBACK GOOD TEM))
1132    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC LC) ;Select halfword (initially rightmost, LC=current+1)
1133    (SETQ TEM (CC-READ-M-MEM CONS-M-SRC-LC))
1134    (COND ((NOT (= TEM LC-READBACK))
1135           (PRINC '|/
1136Wrong value in LC, is |)
1137           (PRIN1 TEM)
1138           (PRINC '|, but should be |)
1139           (PRIN1 LC-READBACK)))
1140    (CC-EXECUTE CONS-IR-OP CONS-OP-BYTE
1141                CONS-IR-A-SRC 1
1142                CONS-IR-M-SRC 2
1143                CONS-IR-BYTL-1 17
1144                CONS-IR-MROT 0
1145                CONS-IR-MF 3
1146                CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-SELECTIVE-DEPOSIT)  ;MR, NO SR
1147    (SETQ TEM (CC-READ-OBUS))
1148    (COND ((NOT (= TEM GOOD))
1149           (PRINC '|/
1150LC=|)
1151           (PRIN1 LC-READBACK)
1152           (PRINC '| (halfword mode), shifter output=|)
1153           (PRIN1 TEM)
1154           (PRINC '|, should be |)
1155           (PRIN1 GOOD))))
1156  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-INT-CNTRL 1_29.) ;Put machine in byte mode
1157  (DOTIMES (B 24.)
1158    (LET ((GOOD (ASH 1 B))
1159          (TEM NIL))
1160      (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC (1- GOOD))
1161      (CC-SAVE-MICRO-STACK)
1162      (SETQ CC-SAVED-MICRO-STACK-PTR 0)
1163      (AS-1 40000 CC-MICRO-STACK 0)
1164      (CC-RESTORE-MICRO-STACK)
1165      (CC-EXECUTE (WRITE)
1166            CONS-IR-OP CONS-OP-JUMP
1167            CONS-IR-R 1
1168            CONS-IR-JUMP-COND CONS-JUMP-COND-UNC)
1169      (COND ((NOT (= (SETQ TEM (LOGAND 77777777 (CC-READ-M-MEM CONS-M-SRC-LC)))
1170                     GOOD))
1171             (FORMAT T "~%LC failed to increment properly good ~s, bad ~s" GOOD TEM)))))
1172)
1173
1174;;; CADR DISPATCH TEST                                           -*-LISP-*-
1175
1176
1177;; Fill all of D memory with its own address, and no RPN bits
1178(DEFUN CC-FILL-D-MEM-W-ADR ()
1179  (DO ((I 0 (1+ I)))
1180      ((= I 2048.))
1181    (DECLARE (FIXNUM I))
1182    (CC-WRITE-D-MEM I I)))
1183
1184;; Read back all possible bytes with MROT=0, make sure right address
1185;; comes back into the PC.  Here we always use a disp addr of 0.
1186(DEFUN CC-TEST-DISPATCH (&aux tem)
1187  (FORMAT T "~&CC-TEST-DISPATCH~%")
1188  (CC-FILL-D-MEM-W-ADR)
1189  (DO ((BYTL 0 (1+ BYTL))
1190       (MXVAL 1 (* MXVAL 2))
1191       (OK-CNT 0)
1192       (ERR-CNT 0))
1193      ((= BYTL 8)
1194       (COND ((NOT (ZEROP ERR-CNT))
1195              (FORMAT T "~%~S TRIALS OK" OK-CNT))))
1196    (DECLARE (FIXNUM BYTL MXVAL))
1197    (DO ((VAL 0 (1+ VAL))
1198         (PC))
1199        ((= VAL MXVAL))
1200      (DECLARE (FIXNUM VAL PC))
1201      (CC-WRITE-MD (- VAL MXVAL)) ;Turn on extra bits to detect improper masking
1202      (CC-EXECUTE CONS-IR-OP CONS-OP-DISPATCH   ;Execute a dispatch
1203                  CONS-IR-M-SRC CONS-M-SRC-MD
1204                  CONS-IR-DISP-BYTL BYTL
1205                  CONS-IR-DISP-ADDR 0)
1206             ;At this point the disp is in IR but has not yet been executed.
1207     (CC-CLOCK)                         ;Clock it so PC loads from disp mem
1208     (SETQ PC (CC-READ-PC))
1209     (COND ((NOT (= PC VAL))            ;Read wrong location
1210            (SETQ ERR-CNT (1+ ERR-CNT))
1211            (TERPRI)
1212            (PRINC '|Dispatch error, BYTL=|)
1213            (PRIN1 BYTL)
1214            (PRINC '|, M=|)
1215            (PRIN1 (LOGAND 37777777777 (- VAL MXVAL)))
1216            (PRINC '|, DPC=|)
1217            (PRIN1 PC)
1218            (PRINC '|, but should be |)
1219            (PRIN1 VAL))
1220           (T (SETQ OK-CNT (1+ OK-CNT))))))
1221  (cc-execute (w-c-mem 0)
1222              cons-ir-op cons-op-dispatch
1223              cons-ir-disp-lpc 1
1224              cons-ir-disp-bytl 0
1225              cons-ir-disp-addr 0)
1226  (cc-write-d-mem 0 (dpb 1 cons-disp-p-bit (dpb 1 cons-disp-n-bit 0)))
1227  (cc-save-micro-stack)
1228  (setq cc-saved-micro-stack-ptr 0)
1229  (as-1 -1 cc-micro-stack 0)
1230  (as-1 -1 cc-micro-stack 1)
1231  (cc-restore-micro-stack)
1232  (cc-write-pc 0)
1233  (cc-noop-clock)       ;dispatch inst to IR
1234  (cc-clock)            ;execute it
1235  (cc-noop-clock)       ;write spc
1236  (cc-save-micro-stack)
1237  (cond ((not (= cc-saved-micro-stack-ptr 1))
1238         (format t "~%Dispatch push failed to advance USP ~s" cc-saved-micro-stack-ptr)))
1239  (cond ((not (= (setq tem (ar-1 cc-micro-stack 1)) 0))
1240         (format t "~%Dispatch push own address at 0 pushed ~s instead" tem)))
1241)
1242
1243
1244(SETQ CC-DIAG-TRACE NIL)  ;T PRINTS ALL ERRORS AS THEY OCCUR
1245
1246(DECLARE (FIXNUM I J K M N NBITS BITNO REGADR PPSS SHIFT RELAD)
1247         (SPECIAL CC-SUSPECT-BIT-LIST CC-DIAG-TRACE CC-TEST-ADR-BARFED))
1248
1249
1250(DEFUN CC-TEST-M-MEM-ADR ()
1251  (CC-TEST-ADR "M-MEM" RAMMO 32. 32. 1))   ;COMMENT, REGADR, WIDTH, # REGISTERS, INITIAL
1252                        ;RELATIVE TEST ADR; M 0 DOESNT WIN SINCE IT GETS CLOBBERED BY
1253                                    ;CC-R-D WHEN WRITING THE MD.
1254
1255(DEFUN CC-TEST-A-MEM-ADR ()
1256  (CC-TEST-ADR "A-MEM" RAAMO 32. 1024. 1)) ;LIKEWISE, A 0 LOSES.
1257
1258(DEFUN CC-TEST-PDL-ADR ()
1259  (CC-TEST-ADR "PDL-BUFFER" RAPBO 32. 1024. 0))
1260
1261
1262;Data test, using progressive shifts of the address and complement of address as data
1263(DEFUN CC-TEST-ADR (MESSAGE REGADR NBITS NREG IRELAD)
1264 (COND ((<= NBITS 36.)  ;FOR SPEED, FIXNUM CASE IS SEPARATE
1265  (DO ((PHASE NIL (NOT PHASE))
1266       (I 0 (IF PHASE (1+ I) I))
1267       (ONES (1- #M (EXPT 2 NBITS) #Q (ASH 1 NBITS)))
1268       (SHIFT)
1269       (ACTUAL)
1270       (CC-TEST-ADR-BARFED NIL)
1271       (ERRORS 0 0)
1272       (ADDRESS-LENGTH (HAULONG NREG)))
1273      ((= I NBITS))
1274    (DECLARE (FIXNUM I SHIFT ONES ACTUAL))      ;This won't win for c-mem,
1275                                                ; but its sooo slow otherwise
1276    (SETQ SHIFT (IF PHASE (- NBITS ADDRESS-LENGTH I) I))
1277    (FORMAT T "~&Data is address shifted ~D places" SHIFT)
1278    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1279        (CC-R-D (+ REGADR RELAD) (LOGAND ONES (ASH RELAD SHIFT))))
1280    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1281        (COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1282                       (LOGAND ONES (ASH RELAD SHIFT))))
1283               (SETQ ERRORS (1+ ERRORS))
1284               (CC-TEST-ADR-BARF MESSAGE RELAD (LOGAND ONES (ASH RELAD SHIFT)) ACTUAL))))
1285    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1286        (CC-R-D (+ REGADR RELAD) (LOGAND ONES (ONES-COMPLEMENT (ASH RELAD SHIFT)))))
1287    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1288        (COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1289                       (LOGAND ONES (ONES-COMPLEMENT (ASH RELAD SHIFT)))))
1290               (SETQ ERRORS (1+ ERRORS))
1291               (CC-TEST-ADR-BARF MESSAGE RELAD (LOGAND ONES (ONES-COMPLEMENT (ASH RELAD SHIFT)))
1292                                 ACTUAL))))
1293;IF THERE WERE ERRORS, GO THRU THE OPPOSITE DIRECTION TO ATTEMPT TO DETERMINE
1294; THE HIGH ADR THAT LOST.
1295    (COND ((NOT (ZEROP ERRORS))
1296           (FORMAT T "~&Scanning down, same parameters~%")
1297           (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
1298               (CC-R-D (+ REGADR RELAD) (LOGAND ONES (ASH RELAD SHIFT))))
1299           (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
1300               (COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1301                              (LOGAND ONES (ASH RELAD SHIFT))))
1302                      (SETQ ERRORS (1+ ERRORS))
1303                      (CC-TEST-ADR-BARF MESSAGE RELAD
1304                                        (LOGAND ONES (ASH RELAD SHIFT)) ACTUAL))))
1305           (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
1306               (CC-R-D (+ REGADR RELAD) (LOGAND ONES (ONES-COMPLEMENT (ASH RELAD SHIFT)))))
1307           (DO RELAD (1- NREG) (1- RELAD) (< RELAD NREG)
1308               (COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1309                              (LOGAND ONES (ONES-COMPLEMENT (ASH RELAD SHIFT)))))
1310                      (SETQ ERRORS (1+ ERRORS))
1311                      (CC-TEST-ADR-BARF MESSAGE RELAD
1312                                        (LOGAND ONES (ONES-COMPLEMENT (ASH RELAD SHIFT)))
1313                                        ACTUAL))))
1314           (TERPRI)))
1315))
1316 (T  ;NON-FIXNUM CASE
1317  (DO ((SHIFT 0 (1+ SHIFT))
1318       (SHIFTMPY 1 (PLUS SHIFTMPY SHIFTMPY))
1319       (ONES (DIFFERENCE #M (EXPT 2 NBITS) #Q (DPB 1 (+ (LSH NBITS 6) 0001) 0) 1))
1320       (ACTUAL)
1321       (CC-TEST-ADR-BARFED NIL)
1322       (ERRORS 0 0))
1323      ((= SHIFT NBITS))
1324    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1325        (CC-R-D (+ REGADR RELAD) (TIMES RELAD SHIFTMPY)))
1326    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1327        (COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1328                           (TIMES RELAD SHIFTMPY)))
1329               (SETQ ERRORS (1+ ERRORS))
1330               (CC-TEST-ADR-BARF MESSAGE RELAD (TIMES RELAD SHIFTMPY) ACTUAL))))
1331    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1332        (CC-R-D (+ REGADR RELAD) (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
1333    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
1334        (COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1335                           (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
1336               (SETQ ERRORS (1+ ERRORS))
1337               (CC-TEST-ADR-BARF MESSAGE RELAD (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))
1338                                 ACTUAL))))
1339;IF THERE WERE ERRORS, GO THRU THE OPPOSITE DIRECTION TO ATTEMPT TO DETERMINE
1340; THE HIGH ADR THAT LOST.
1341    (COND ((NOT (ZEROP ERRORS))
1342           (PRINC "SCANNING DOWN, SAME PARAMETERS")
1343           (TERPRI)
1344           (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
1345               (CC-R-D (+ REGADR RELAD) (TIMES RELAD SHIFTMPY)))
1346           (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
1347               (COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1348                                  (TIMES RELAD SHIFTMPY)))
1349                      (SETQ ERRORS (1+ ERRORS))
1350                      (CC-TEST-ADR-BARF MESSAGE RELAD (TIMES RELAD SHIFTMPY) ACTUAL))))
1351           (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
1352               (CC-R-D (+ REGADR RELAD) (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
1353           (DO RELAD (1- NREG) (1- RELAD) (< RELAD NREG)
1354               (COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
1355                                  (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
1356                      (SETQ ERRORS (1+ ERRORS))
1357                      (CC-TEST-ADR-BARF MESSAGE RELAD
1358                                        (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))
1359                                        ACTUAL))))
1360           (TERPRI)))
1361))))
1362
1363(DEFUN CC-TEST-ADR-BARF (MESSAGE RELAD GOOD BAD)
1364  (COND ((NOT CC-TEST-ADR-BARFED)
1365         (SETQ CC-TEST-ADR-BARFED T)
1366         (PRINC "Error while address-testing ") (PRINC MESSAGE) (TERPRI)))
1367  (PRINC "Rel addr ") (PRIN1 RELAD)
1368  (PRINC " wrote ") (PRIN1 GOOD)
1369  (PRINC " read ") (PRIN1  BAD) (TERPRI))
1370
1371(DEFUN CC-ASSURE-C-MEM-ZERO (&OPTIONAL (START 0)(END 20000))
1372  (DO ((ADR START (1+ ADR))
1373       (C-MEM-CONTENTS)
1374       (C-MEM-HIGH) (C-MEM-MEDIUM) (C-MEM-LOW)
1375       (HIGH-BAD-AND 177777)
1376       (MEDIUM-BAD-AND 177777)
1377       (LOW-BAD-AND 177777)
1378       (HIGH-BAD-OR 0)
1379       (MEDIUM-BAD-OR 0)
1380       (LOW-BAD-OR 0)
1381       (BAD-ADDRESS-AND 177777)
1382       (BAD-ADDRESS-OR 0))
1383      ((>= ADR END) (FORMAT T "~%AND of non-zero locations: ~O~%OR of non-zero locations: ~O
1384AND of bad addresses: ~O~%OR of bad address: ~O"
1385                           (+ (ASH HIGH-BAD-AND 40) (ASH MEDIUM-BAD-AND 20) LOW-BAD-AND)
1386                           (+ (ASH HIGH-BAD-OR 40) (ASH MEDIUM-BAD-OR 20) LOW-BAD-OR)
1387                           BAD-ADDRESS-AND
1388                           BAD-ADDRESS-OR))
1389      (COND ((NOT (ZEROP (SETQ C-MEM-CONTENTS (CC-READ-C-MEM ADR))))
1390             (SETQ BAD-ADDRESS-AND (LOGAND BAD-ADDRESS-AND ADR)
1391                   BAD-ADDRESS-OR (LOGIOR BAD-ADDRESS-OR ADR)
1392                   C-MEM-HIGH (LDB 4020 C-MEM-CONTENTS)
1393                   C-MEM-MEDIUM (LDB 2020 C-MEM-CONTENTS)
1394                   C-MEM-LOW (LDB 0020 C-MEM-CONTENTS))
1395             (SETQ HIGH-BAD-AND (LOGAND HIGH-BAD-AND C-MEM-HIGH)
1396                   MEDIUM-BAD-AND (LOGAND MEDIUM-BAD-AND C-MEM-MEDIUM)
1397                   LOW-BAD-AND (LOGAND LOW-BAD-AND C-MEM-LOW)
1398
1399                   HIGH-BAD-OR (LOGIOR HIGH-BAD-OR C-MEM-HIGH)
1400                   MEDIUM-BAD-OR (LOGIOR MEDIUM-BAD-OR C-MEM-MEDIUM)
1401                   LOW-BAD-OR (LOGIOR LOW-BAD-OR C-MEM-LOW))))))
1402
1403
1404;CC-ZERO-C-MEM defined in LMCONS;ZERO
1405(DEFUN CC-ZERO-C-MEM-CONTINUOUS ()
1406  (CC-EXECUTE (W-C-MEM 0)
1407        CONS-IR-OP CONS-OP-BYTE
1408        CONS-IR-M-SRC CONS-M-SRC-MD
1409        CONS-IR-A-SRC 1
1410        CONS-IR-BYTE-FUNC CONS-BYTE-FUNC-DPB
1411        CONS-IR-MROT 12.
1412        CONS-IR-BYTL-1 13.
1413        CONS-IR-FUNC-DEST CONS-FUNC-DEST-OA-LOW)
1414  (CC-EXECUTE (W-C-MEM 1)
1415        CONS-IR-OP CONS-OP-JUMP
1416        CONS-IR-A-SRC 1 ;VALUE TO WRITE (HIGH)
1417        CONS-IR-M-SRC 1 ;VALUE TO WRITE (LOW)
1418        CONS-IR-JUMP-ADDR 0
1419        CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
1420        CONS-IR-R 1
1421        CONS-IR-P 1
1422        CONS-IR-N 1)
1423  (CC-EXECUTE (W-C-MEM 2)
1424        CONS-IR-STAT-BIT 1
1425        CONS-IR-M-SRC CONS-M-SRC-MD
1426        CONS-IR-OB CONS-OB-ALU
1427        CONS-IR-ALUF CONS-ALU-M+1
1428        CONS-IR-FUNC-DEST CONS-FUNC-DEST-MD)
1429  (CC-EXECUTE (W-C-MEM 3)
1430        CONS-IR-OP CONS-OP-JUMP
1431        CONS-IR-JUMP-ADDR 0
1432        CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
1433        CONS-IR-N 1)
1434  (DO () ((KBD-TYI-NO-HANG))
1435      (CC-WRITE-STAT-COUNTER -16380.) ;STOP AFTER WRITING 16K-4 LOCATIONS
1436      (CC-WRITE-M-MEM 1 0)
1437      (CC-WRITE-MD 4) ;STARTING AT 4
1438      (CC-RUN-TEST-LOOP 0))
1439)
1440
1441(DEFUN CC-TEST-C-MEM-PARITY-CHECKER NIL
1442  (DO ((BIT 0 (1+ BIT))
1443       (QUAN))
1444      ((= BIT 47.))
1445    (CC-WRITE-C-MEM 0 (SETQ QUAN (ASH 1 BIT)))
1446    (CC-EXECUTE (WRITE)
1447                CONS-IR-OP CONS-OP-JUMP ;DO JUMP INSTRUCTION TO DESIRED PLACE
1448                CONS-IR-JUMP-ADDR 0
1449                CONS-IR-JUMP-COND CONS-JUMP-COND-UNC)
1450       (COND ((NOT (= QUAN (CC-READ-IR)))
1451              (FORMAT T "~%~WROTE ~O READ ~O" QUAN (CC-READ-IR))))
1452       (CC-NOOP-CLOCK)
1453       (COND ((NOT (ZEROP (LOGLDB 501 (SPY-READ SPY-FLAG-1))))
1454              (FORMAT T "~%parity checker failed BIT ~D." BIT)))))
1455
1456(DEFUN CC-MEM-TEST-LOOP (ADR &OPTIONAL WRITE-DATA READ-ALSO)
1457  (COND (WRITE-DATA
1458         (DO ((WORD)) ((KBD-TYI-NO-HANG) (PHYS-MEM-READ ADR))
1459             (AND WORD (RETURN-ARRAY WORD))
1460             (PHYS-MEM-WRITE ADR WRITE-DATA)
1461             (AND READ-ALSO (SETQ WORD (PHYS-MEM-READ ADR)))))
1462        (T
1463         (DO ((WORD)) ((KBD-TYI-NO-HANG) WORD)
1464             (AND WORD (RETURN-ARRAY WORD))
1465             (SETQ WORD (PHYS-MEM-READ ADR))))))
1466
1467(DEFUN CC-MEM-ZERO (FROM TO)
1468  (DO ((ADR FROM (1+ ADR)))
1469      ((OR (KBD-TYI-NO-HANG) (> ADR TO)) ADR)
1470      (PHYS-MEM-WRITE ADR 0)))
1471
1472;;; Perform a read or write, check specified status bits.
1473(DEFUN DC-CLP-NXM (&AUX STATUS)
1474  (DO () ((KBD-TYI-NO-HANG) STATUS)
1475      (PHYS-MEM-WRITE DC-CLP-ADR 400000)
1476      (PHYS-MEM-WRITE DC-CMD-ADR 0)
1477      (PHYS-MEM-WRITE DC-START-ADR 0)
1478      (DO () ((LDB-TEST 0001 (SETQ STATUS (PHYS-MEM-READ DC-STS-ADR)))))))
1479
1480
1481(DEFUN CC-MEM-FILL (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION (LAMBDA (X) (1+ X)))))
1482  (DO ((ADR FROM (1+ ADR))
1483       (WORD WORD (FUNCALL FUNCTION WORD)))
1484      ((OR (KBD-TYI-NO-HANG) (> ADR TO)) ADR)
1485      (PHYS-MEM-WRITE ADR WORD)))
1486
1487(DEFUN CC-MEM-FILL-CHECK (FROM TO &OPTIONAL (WORD 0)
1488                                            (FUNCTION (FUNCTION (LAMBDA (X) (1+ X)))))
1489  (DO ((ADR FROM (1+ ADR))
1490       (MEM-WORD 0)
1491       (WORD WORD (FUNCALL FUNCTION WORD)))
1492      ((OR (KBD-TYI-NO-HANG) (> ADR TO)) ADR)
1493      (OR (= (SETQ MEM-WORD (PHYS-MEM-READ ADR)) WORD)
1494          (FORMAT T "Compare error: Adr=~O, is ~O but should be ~O~%" ADR MEM-WORD WORD))))
1495
1496(DEFUN CC-MEM-TEST-ONE-WORD-TO-DISK (ADR &OPTIONAL (WORD 0)
1497                                     PRINT-FLAG (FUNCTION (FUNCTION 1+)))
1498  (DO ((CORE-PAGE (// ADR 400))
1499       (WORD WORD (FUNCALL FUNCTION WORD)))
1500      ((KBD-TYI-NO-HANG) WORD)
1501      (AND PRINT-FLAG (PRINC WORD) (PRINC " "))
1502      (PHYS-MEM-WRITE ADR WORD)
1503      (CC-DISK-WRITE 1 CORE-PAGE 1)))
1504
1505(DEFUN CC-MEM-READ-DISK (ADR)
1506  (CC-DISK-READ 1 (// ADR 400) 1))
1507
1508(DEFUN CC-DISK-REPEAT-OP (CORE-PAGE &OPTIONAL SLEEP-TIME
1509                                    ERROR-PRINT-FLAG (FCN CC-DISK-WRITE-FCN))
1510  (PHYS-MEM-WRITE 12 (LSH CORE-PAGE 8))
1511  (DO ((STATUS))
1512      ((KBD-TYI-NO-HANG))
1513      (AND SLEEP-TIME (PROCESS-SLEEP SLEEP-TIME))
1514      (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 0) FCN) ;Store command, does reset
1515      (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 1) 12)  ;Store CLP
1516      (SETQ CC-DISK-LAST-CMD FCN CC-DISK-LAST-CLP 12)
1517      (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 2) 1)  ;Disk adr: always track 0, head 0, sector 1
1518      (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 3) 0)   ;Start transfer
1519      (DO () ((NOT (ZEROP (LDB 0001 (SETQ STATUS (PHYS-MEM-READ CC-DISK-ADDRESS)))))))
1520      (COND ((AND ERROR-PRINT-FLAG
1521                  (NOT (ZEROP (LOGAND STATUS 47777560))))
1522             ; ERROR BITS: INTERNAL PARITY, NXM, MEM PAR, HEADER COMPARE,
1523             ; HEADER ECC, ECC HARD, ECC SOFT, READ OVERRUN, WRITE OVERRUN,
1524             ; START-BLOCK ERR, TIMEOUT, SEEK ERR, OFF LINE, OFF CYL, FAULT,
1525             ;    NO SEL, MUL SEL
1526             (CC-DISK-ANALYZE)))))
1527
1528;; MAP FIRST 256K VIRTUAL MEMORY TO PHYSICAL MEMORY
1529(DEFUN CC-LOAD-STRAIGHT-MAP (&OPTIONAL (PAGE-OFFSET 0))
1530  (DO ((L-2 0 (1+ L-2)))
1531      (( L-2 1024.))
1532      (CC-WRITE-LEVEL-2-MAP L-2 (+ 60000000 L-2 PAGE-OFFSET)))
1533  (DO ((L-1 0 (1+ L-1)))
1534      (( L-1 40))
1535      (CC-WRITE-LEVEL-1-MAP L-1 L-1)))
1536
1537(DEFMACRO CC-MEMORY-BANK (VMA)
1538  `(LDB 1612 ,VMA))
1539
1540(DEFUN CC-PARITY-SWEEP-INFO (PHYS-ADR-LIST &OPTIONAL (PRINT-AREA-SYMBOL T))
1541  (DO ((L PHYS-ADR-LIST (CDR L))
1542       (PHYS-ADR) (VIRT-ADR) (AREA-NUMBER) (AREA-SYMBOL) (CORE) (DISK))
1543      ((NULL L) NIL)
1544    (SETQ PHYS-ADR (CAR L) VIRT-ADR (QF-VIRT-ADR-OF-PHYS-ADR PHYS-ADR)
1545          AREA-NUMBER (QF-AREA-NUMBER-OF-POINTER VIRT-ADR)
1546          AREA-SYMBOL (COND (PRINT-AREA-SYMBOL
1547                              (READLIST (CC-Q-EXPLODE (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN
1548                                                                        'AREA-NAME)
1549                                                                      AREA-NUMBER)))))))
1550    (FORMAT T "~%~S: Virtual adr ~S, Area ~S " PHYS-ADR VIRT-ADR AREA-SYMBOL)
1551    (FORMAT T " Core copy ~O, Disk copy ~O  bits:"
1552            (SETQ CORE (QF-MEM-READ VIRT-ADR))
1553            (SETQ DISK (QF-MEM-READ-DISK-COPY VIRT-ADR)))
1554    (CC-PRINT-BITS (LOGXOR CORE DISK)))
1555)
1556
1557(DEFUN CC-PARITY-SWEEP (&OPTIONAL (NUMBER-OF-MEMORIES 2)
1558                                  VERBOSE-P FIX-ERRORS-P
1559                                  (FIRST-ADDRESS 0)
1560                        &AUX (C-MEM-SAVE-LIST '(17000 17001 17002 17003)))
1561  (LET ((SAVED-CONTROL-MEMORY (MAPCAR #'CC-READ-C-MEM C-MEM-SAVE-LIST))
1562        (CURRENT-DATA-LOGAND) (CURRENT-DATA-LOGIOR)
1563        (CURRENT-ADR-LOGAND) (CURRENT-ADR-LOGIOR)
1564        (CURRENT-BANK (CC-MEMORY-BANK FIRST-ADDRESS))
1565        (ERROR-FLAG NIL) (MEM-SIZE (LSH NUMBER-OF-MEMORIES 16.))
1566        (BAD-LOCS))
1567    (DBG-RESET)                         ;TEMPORARY KLUDGE?  JUST IN CASE MACHINE IS HUNG
1568    (CC-RESET-MACH)
1569    (SPY-WRITE SPY-MODE 44)             ;Prom disable, errhalt
1570    (CC-FAST-LOAD-STRAIGHT-MAP)
1571    (CC-EXECUTE (W-C-MEM 17000)
1572                CONS-IR-OP CONS-OP-ALU
1573                CONS-IR-M-SRC CONS-M-SRC-VMA
1574                CONS-IR-OB CONS-OB-ALU
1575                CONS-IR-ALUF CONS-ALU-M+1
1576                CONS-IR-FUNC-DEST CONS-FUNC-DEST-VMA-START-READ)
1577    (CC-EXECUTE (W-C-MEM 17001)
1578                CONS-IR-STAT-BIT 1)     ;DELAY (NO PAGE FAULT EXPECTED)
1579    (CC-EXECUTE (W-C-MEM 17002)
1580                CONS-IR-M-SRC CONS-M-SRC-MD
1581                CONS-IR-OB CONS-OB-ALU
1582                CONS-IR-ALUF CONS-ALU-SETM)     ;DEST M-GARBAGE
1583    (CC-EXECUTE (W-C-MEM 17003)
1584                CONS-IR-OP CONS-OP-JUMP
1585                CONS-IR-JUMP-ADDR 17000
1586                CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
1587                CONS-IR-N 1)
1588    (SETQ MEM-SIZE (- MEM-SIZE FIRST-ADDRESS))
1589    (CC-WRITE-STAT-COUNTER (1- MEM-SIZE))
1590    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA (1- FIRST-ADDRESS))
1591    (SETQ CURRENT-DATA-LOGAND -1  CURRENT-DATA-LOGIOR 0
1592          CURRENT-ADR-LOGAND -1  CURRENT-ADR-LOGIOR 0)
1593    (DO () (NIL)
1594      (CC-RUN-TEST-LOOP-W-ERROR-HALTS 17000)
1595      (LET ((VMA (CC-READ-M-MEM CONS-M-SRC-VMA))
1596            (MD (CC-READ-M-MEM CONS-M-SRC-MD)))
1597        (COND (( (CC-MEMORY-BANK VMA) CURRENT-BANK)
1598               (COND (ERROR-FLAG
1599                       (CC-PRINT-BANK-AS-BOARD-AND-BANK CURRENT-BANK)
1600                       (FORMAT T "~&Address LOGAND=~O, Address LOGIOR=~O, Data LOGAND=~O, Data LOGIOR=~O~%"
1601                               (LOGAND CURRENT-ADR-LOGAND (1- (ASH 1 24.)))
1602                               CURRENT-ADR-LOGIOR
1603                               (LOGAND CURRENT-DATA-LOGAND (1- (ASH 1 32.)))
1604                               CURRENT-DATA-LOGIOR)))
1605               (SETQ CURRENT-DATA-LOGAND -1  CURRENT-DATA-LOGIOR 0
1606                     CURRENT-ADR-LOGAND -1  CURRENT-ADR-LOGIOR 0
1607                     CURRENT-BANK (CC-MEMORY-BANK VMA)
1608                     ERROR-FLAG NIL)))
1609        (COND ((> VMA (+ FIRST-ADDRESS MEM-SIZE -1))
1610               (RETURN T))
1611              (T (AND VERBOSE-P
1612                      (FORMAT T "~%VMA: ~O MD: ~O" VMA MD))
1613                 (SETQ ERROR-FLAG T
1614                       CURRENT-ADR-LOGAND (LOGAND CURRENT-ADR-LOGAND VMA)
1615                       CURRENT-ADR-LOGIOR (LOGIOR CURRENT-ADR-LOGIOR VMA)
1616                       CURRENT-DATA-LOGAND (LOGAND CURRENT-DATA-LOGAND MD)
1617                       CURRENT-DATA-LOGIOR (LOGIOR CURRENT-DATA-LOGAND MD)
1618                       BAD-LOCS (CONS VMA BAD-LOCS))
1619                 (AND FIX-ERRORS-P
1620                      (PHYS-MEM-WRITE VMA (PHYS-MEM-READ VMA)))))))
1621    (DOLIST (LOC C-MEM-SAVE-LIST)
1622      (CC-WRITE-C-MEM LOC (CAR SAVED-CONTROL-MEMORY))
1623      (SETQ SAVED-CONTROL-MEMORY (CDR SAVED-CONTROL-MEMORY)))
1624    BAD-LOCS))
1625
1626(DEFUN CC-PRINT-BANK-AS-BOARD-AND-BANK (BANK)
1627  (LET ((BOARD (FIX (// BANK 4))))
1628    (FORMAT T "~&Bank ~O, which is Bank ~O of Board ~O  (based from zero)~%"
1629          BANK (- BANK (* BOARD 4)) BOARD)
1630    T))
1631
1632
1633(DEFUN CC-RUN-TEST-LOOP-W-ERROR-HALTS (ADR)
1634  (CC-WRITE-PC ADR)
1635  (CC-NOOP-CLOCK)               ;FIRST INSTRUCTION TO IR
1636  (CC-CLOCK)                    ;CLOCK AGAIN
1637  (SPY-WRITE SPY-MODE 54)  ;ENABLE STAT HALT, PROM DISABLE, ERR HALT
1638  (SPY-WRITE SPY-CLK 1) ;TAKE OFF
1639  (DO () ((BIT-TEST 6000 (LOGXOR 4000 (SPY-READ SPY-FLAG-1))))
1640    #M (SLEEP 1)
1641    #Q (PROCESS-SLEEP 15.))         ;AWAIT STAT HALT
1642  )
1643
1644;;; Function for testing and adjusting the clock
1645
1646(declare (special cc-adjust-clock-array))
1647
1648(defun cc-test-clock ()
1649  (or (boundp 'cc-adjust-clock-array)
1650      (setq cc-adjust-clock-array (*array nil 'fixnum 8)))
1651  ;These first two are to get everything paged in
1652  (cc-measure-clock 0)
1653  (cc-measure-clock 4)
1654  (do i 0 (1+ i) (= i 8)
1655    (store (arraycall fixnum cc-adjust-clock-array i)
1656           (cc-measure-clock i)))
1657  (princ "
1658Speed   ILong     Pin   Actual  Nominal
1659")
1660  (do ((i 0 (1+ i))
1661       (pins '(5D08-6 5D08-4 5D08-17 5D08-15 5D08-5 5D08-3 5D08-16 5D08-14) (cdr pins))
1662       (nominals '(235. 180. 170. 160. 235. 220. 210. 200.) (cdr nominals)))
1663      ((= i 8))
1664    (format t "  ~D     ~:[no~;yes~]    ~A        ~D      ~D~%"
1665              (logand 3 i) (> i 3) (car pins) (arraycall fixnum cc-adjust-clock-array i)
1666              (car nominals)))
1667  (format t "~%Also, scope clock at 5A10-11; width of low phase should be about 75 ns~%"))
1668
1669;Returns period in nanoseconds
1670;I guess this isn't going to work on the 10
1671(defun cc-measure-clock (speed-ilong &aux start-time end-time)
1672  (cc-write-md 0)  ;Will count cycles
1673  (cond ((< speed-ilong 4)
1674         (cc-execute cons-ir-m-src cons-m-src-md
1675                     cons-ir-ob cons-ob-alu
1676                     cons-ir-aluf cons-alu-M+1
1677                     cons-ir-func-dest cons-func-dest-md))
1678        (t
1679         (cc-execute cons-ir-ilong 1
1680                     cons-ir-m-src cons-m-src-md
1681                     cons-ir-ob cons-ob-alu
1682                     cons-ir-aluf cons-alu-M+1
1683                     cons-ir-func-dest cons-func-dest-md)))
1684  (spy-write spy-mode (logand 3 speed-ilong)) ;Set speed, clear errstop, etc.
1685  (spy-write spy-clk 11)        ;Set RUN and DEBUG
1686  (let ((low (%unibus-read 764120))  ;Hardware synchronizes if you read this one first
1687        (high (%unibus-read 764122)))
1688    (setq start-time (dpb high 2007 low)))
1689  (process-sleep 60.)
1690  (spy-write spy-clk 10)        ;Clear RUN, but leave DEBUG set
1691  (let ((low (%unibus-read 764120))  ;Hardware synchronizes if you read this one first
1692        (high (%unibus-read 764122)))
1693    (setq end-time (dpb high 2007 low)))
1694  (// (* (cond ((> end-time start-time) (- end-time start-time))
1695               (t (+ (- end-time start-time) 1_23.)))
1696         1000.)
1697      (cc-read-m-mem cons-m-src-md)))
1698
1699;;; Testing of instruction-modification paths.  The general methodology is
1700;;; to execute an instruction which has an OA destination,
1701;;; then read back the IR.  With one side of the IOB or-gates held low we
1702;;; test the bits on the other side.  First we put the OA-modifying instruction into
1703;;; the IR, then we put the desired value for the I lines into the DEBUG-IR
1704;;; then do a DEBUG-CLOCK.
1705(DEFUN CC-TEST-OA-REGS ()
1706  (CC-TEST-OA-REG "OA-REG-LOW" CONS-FUNC-DEST-OA-LOW 0 26. 1 0)
1707  (CC-TEST-OA-REG "OA-REG-LOW" CONS-FUNC-DEST-OA-LOW 0 26. 0 1)
1708  (CC-TEST-OA-REG "OA-REG-HIGH" CONS-FUNC-DEST-OA-HIGH 26. 22. 1 0)
1709  (CC-TEST-OA-REG "OA-REG-HIGH" CONS-FUNC-DEST-OA-HIGH 26. 22. 0 1))
1710
1711;;; Float a 1 bit through and complain about wrong 1's or 0's
1712;;; Conceivably could float 0's also.
1713(DEFUN CC-TEST-OA-REG (MESSAGE DEST FIRST-IR-BIT N-BITS IR-BIT M-BIT)
1714  (DO ((N N-BITS (1- N))
1715       (IR-BIT (ASH IR-BIT FIRST-IR-BIT) (ASH IR-BIT 1))
1716       (M-BIT M-BIT (ASH M-BIT 1))
1717       (BITNO 0 (1+ BITNO))
1718       (GOOD)(BAD)
1719       (CC-SUSPECT-BIT-LIST NIL)
1720       (BASE 10.)
1721       (*NOPOINT T))
1722      ((ZEROP N))
1723    (CC-WRITE-MD M-BIT)
1724    (CC-EXECUTE
1725        CONS-IR-M-SRC CONS-M-SRC-MD
1726        CONS-IR-OB CONS-OB-ALU
1727        CONS-IR-ALUF CONS-ALU-SETM
1728        CONS-IR-FUNC-DEST DEST)
1729    (CC-WRITE-DIAG-IR IR-BIT)
1730    (CC-DEBUG-CLOCK)
1731    ;; IR should now have OR of M-BIT and IR-BIT
1732    (SETQ GOOD (LOGIOR IR-BIT (ASH M-BIT FIRST-IR-BIT))
1733          BAD (CC-READ-IR))
1734    (COND ((NOT (= GOOD BAD))
1735           (PRINC MESSAGE)
1736           (PRINC " failure: ")
1737           (COND ((ZEROP IR-BIT)
1738                  (PRINC "OB has 1 in bit ")
1739                  (PRIN1 BITNO)
1740                  (COND ((NOT (ZEROP FIRST-IR-BIT))
1741                         (PRINC " (=")
1742                         (PRIN1 (+ BITNO FIRST-IR-BIT))
1743                         (PRINC ")")))
1744                  (PRINC ", I"))
1745                 (T (PRINC "I has 1 in bit ")
1746                    (PRIN1 (+ BITNO FIRST-IR-BIT))
1747                    (PRINC ", OB")))
1748           (COND ((ZEROP BAD)
1749                  (PRINC " has zero.  IR got zero")
1750                  (TERPRI))
1751                 ((CC-PRINT-BIT-LIST " has zero.  1-bits in IR: "
1752                                     (CC-WRONG-BITS-LIST 0 BAD 48.))))))))
1753
1754
1755(DEFVAR CC-RANDOM-DATA-ARRAY NIL)
1756(DEFVAR CC-RANDOM-DATA-ARRAY-COMPLEMENTED NIL)
1757
1758;This one takes a while.  Run it when you are out to lunch.
1759(DEFUN CC-C-MEM-BLOCK-ADDRESS-TEST (&OPTIONAL (ISA 0))
1760   (COND ((NULL CC-RANDOM-DATA-ARRAY)
1761          (SETQ CC-RANDOM-DATA-ARRAY (MAKE-ARRAY NIL ART-Q 400))
1762          (SETQ CC-RANDOM-DATA-ARRAY-COMPLEMENTED (MAKE-ARRAY NIL ART-Q 400))
1763          (DO I 0 (1+ I) (= I 400)
1764              (AS-1 (LOGXOR (AS-1 (DPB (RANDOM 200000)
1765                                       4020
1766                                       (DPB (RANDOM 200000)
1767                                            2020
1768                                            (RANDOM 200000)))
1769                                  CC-RANDOM-DATA-ARRAY
1770                                  I)
1771                            7777777777777777)
1772                    CC-RANDOM-DATA-ARRAY-COMPLEMENTED
1773                    I))))
1774   (*CATCH 'BLOCK-TEST
1775        (DO SA ISA (+ SA 400) (= SA 40000)
1776            (CC-CMB-TEST SA))))
1777
1778(DEFUN CC-CMB-TEST (SA)
1779   (CC-CMB-WRITE-BLOCK SA CC-RANDOM-DATA-ARRAY)
1780   (COND ((NOT (ZEROP (CC-CMB-TEST-BLOCK SA CC-RANDOM-DATA-ARRAY)))
1781          (FORMAT T "~%400 wd block at ~s doesnt retain data" SA))
1782         (T (CC-CMB-ZAP SA 0 SA 0)
1783            (CC-CMB-ZAP SA (+ SA 400) 40000 0)
1784            (COND ((NOT (ZEROP (CC-CMB-TEST-BLOCK SA CC-RANDOM-DATA-ARRAY)))
1785                   (FORMAT T "~%400 wd block at ~S changed by writing 0's elsewhere" SA)))
1786            (CC-CMB-ZAP SA 0 SA -1)
1787            (CC-CMB-ZAP SA (+ SA 400) 40000 0)
1788            (COND ((NOT (ZEROP (CC-CMB-TEST-BLOCK SA CC-RANDOM-DATA-ARRAY)))
1789                   (FORMAT T "~%400 wd block at ~S changed by writing 1's elsewhere" SA)))
1790            (CC-CMB-WRITE-BLOCK SA CC-RANDOM-DATA-ARRAY-COMPLEMENTED)
1791            (COND ((NOT (ZEROP (CC-CMB-TEST-BLOCK SA CC-RANDOM-DATA-ARRAY-COMPLEMENTED)))
1792                   (FORMAT T "~%400 wd block at ~s doesn't retain (complemented) data" SA)))
1793            (CC-CMB-ZAP SA 0 SA 0)
1794            (CC-CMB-ZAP SA (+ SA 400) 40000 0)
1795            (COND ((NOT (ZEROP (CC-CMB-TEST-BLOCK SA CC-RANDOM-DATA-ARRAY-COMPLEMENTED)))
1796                   (FORMAT T "~%400 wd block at ~S changed by writing 0's elsewhere (COM)"
1797                           SA)))
1798            (CC-CMB-ZAP SA 0 SA -1)
1799            (CC-CMB-ZAP SA (+ SA 400) 40000 0)
1800            (COND ((NOT (ZEROP (CC-CMB-TEST-BLOCK SA CC-RANDOM-DATA-ARRAY-COMPLEMENTED)))
1801                   (FORMAT T "~%400 wd block at ~S changed by writing 1's elsewhere(COM)"
1802                           SA))))))
1803
1804(DEFUN CC-CMB-ZAP (SA FROM TO DATA)
1805  (COND ((KBD-TYI-NO-HANG)
1806         (FORMAT T "~%WAS TESTING BLOCK AT ~S" SA)
1807         (*THROW 'BLOCK-TEST NIL)))
1808  (CC-WRITE-A-MEM 1 (LOGLDB 4020 DATA)) ;1@A GETS HIGH 16 BITS
1809  (CC-WRITE-M-MEM 0 (DPB (LDB 2020 DATA) 2020 (LDB 0020 DATA))) ;0@M GETS LOW 32 BITS
1810  (DO I FROM (1+ I) (NOT (< I TO))
1811      (CC-EXECUTE (WRITE)
1812              CONS-IR-OP CONS-OP-JUMP   ;EXECUTE MAGIC FLAVOR OF JUMP INSTRUCTION
1813              CONS-IR-JUMP-ADDR I
1814              CONS-IR-P 1               ;R+P=WRITE C MEM
1815              CONS-IR-R 1
1816              CONS-IR-A-SRC 1
1817              ;CONS-IR-M-SRC 0
1818              CONS-IR-JUMP-COND CONS-JUMP-COND-UNC)))
1819
1820
1821(DEFUN CC-CMB-WRITE-BLOCK (SA ARY)
1822   (DO I 0 (1+ I) (= I 400)
1823       (CC-WRITE-C-MEM (+ SA I) (AR-1 ARY I))))
1824
1825(DEFUN CC-CMB-TEST-BLOCK (SA ARY &AUX (ERRS 0) RES)
1826   (DO ((I 0 (1+ I)))
1827       ((OR (= I 400)
1828            (AND (NULL CC-DIAG-TRACE)
1829                 (NOT (ZEROP ERRS))))
1830        ERRS)
1831     (COND ((NOT (= (SETQ RES (CC-READ-C-MEM (+ SA I))) (AR-1 ARY I)))
1832            (SETQ ERRS (1+ ERRS))
1833            (COND (CC-DIAG-TRACE
1834                   (FORMAT T "~%ADR:~S READ ~S, SHOULD BE ~S" (+ I SA) RES (AR-1 ARY I))))))))
1835
1836
1837;ALU TESTS
1838
1839(DEFUN CC-TEST-INCREMENTER ()
1840 (DO ((BIT 0 (1+ BIT))
1841      (DAT)
1842      (RES))
1843     ((= BIT 32.))
1844   (CC-WRITE-M-MEM 1 (1- (SETQ DAT (ASH 1 BIT))))
1845   (CC-EXECUTE
1846     CONS-IR-OP CONS-OP-ALU
1847     CONS-IR-M-SRC 1
1848     CONS-IR-OB CONS-OB-ALU
1849     CONS-IR-ALUF CONS-ALU-M+1)
1850   (COND ((NOT (= (SETQ RES (CC-READ-OBUS)) DAT))
1851          (FORMAT T "~%Incrementing bit ~D, got ~o instead of ~o" BIT RES DAT)))))
1852
1853(DEFUN CC-TEST-ARITH-COND-JUMP ()
1854  (DO ((BIT 0 (1+ BIT))
1855       (DAT))
1856      ((= BIT 31.))
1857    (SETQ DAT (ASH 1 BIT))
1858    (CC-WRITE-M-MEM 1 DAT)
1859    (CC-WRITE-M-MEM 2 (1- DAT))
1860    (CC-WRITE-M-MEM 3 (MINUS DAT))
1861    (CC-WRITE-M-MEM 4 (MINUS (1- DAT)))
1862    (DO ((I 1 (1+ I)))
1863        ((= I 4))
1864      (CC-TEST-JUMP-INTERNAL I I CONS-JUMP-COND-M=A "M=A" T)
1865      (CC-TEST-JUMP-INTERNAL I I CONS-JUMP-COND-M<A "M<A" NIL)
1866      (CC-TEST-JUMP-INTERNAL I I CONS-JUMP-COND-M>A "M>A" NIL)
1867      (CC-TEST-JUMP-INTERNAL I I CONS-JUMP-COND-M<=A "M<=A" T)
1868      (CC-TEST-JUMP-INTERNAL I I CONS-JUMP-COND-M>=A "M>=A" T))
1869    (CC-TEST-JUMP-1 2 1)
1870    (CC-TEST-JUMP-1 3 4)))
1871
1872(DEFUN CC-TEST-JUMP-1 (LESS MORE)
1873  (CC-TEST-JUMP-INTERNAL LESS MORE CONS-JUMP-COND-M<A "M<A" T)
1874  (CC-TEST-JUMP-INTERNAL MORE LESS CONS-JUMP-COND-M<A "M<A" NIL)
1875  (CC-TEST-JUMP-INTERNAL LESS MORE CONS-JUMP-COND-M>A "M>A" NIL)
1876  (CC-TEST-JUMP-INTERNAL MORE LESS CONS-JUMP-COND-M>A "M>A" T))
1877
1878(DEFUN CC-TEST-JUMP-INTERNAL (M-ADR A-ADR JUMP-COND STRING SHOULD-JUMP
1879                     &AUX NPC JCOND WILL-JUMP ERR)
1880  (CC-WRITE-PC 0)
1881  (CC-EXECUTE
1882     CONS-IR-OP CONS-OP-JUMP
1883     CONS-IR-M-SRC M-ADR
1884     CONS-IR-A-SRC A-ADR
1885     CONS-IR-JUMP-COND JUMP-COND
1886     CONS-IR-JUMP-ADDR 777)
1887  (SETQ JCOND (LDB 0201 (SPY-READ SPY-FLAG-2)))
1888  (SETQ WILL-JUMP (NOT (OR (AND (NOT (ZEROP JCOND)) (ZEROP (LDB 0601 JUMP-COND)))
1889                           (AND (ZEROP JCOND) (NOT (ZEROP (LDB 0601 JUMP-COND)))))))
1890  (COND ((EQ WILL-JUMP SHOULD-JUMP)
1891         (FORMAT T "~%JCOND incorrect before clock")  ;note! dont believe this error too much.
1892         (SETQ ERR T)))
1893  (CC-CLOCK)
1894  (SETQ NPC (CC-READ-PC))
1895  (COND ((NOT (= NPC (COND (SHOULD-JUMP 777) (T 2))))
1896         (FORMAT T "~%JUMP FAILED: M=~O, A=~O, COND ~A, NPC=~O"
1897                 (CC-READ-M-MEM M-ADR)
1898                 (CC-READ-A-MEM A-ADR)
1899                 STRING
1900                 NPC))
1901        (ERR (FORMAT T "~%Actual jump OK: M=~O, A=~O, COND ~A, NPC=~O"
1902                 (CC-READ-M-MEM M-ADR)
1903                 (CC-READ-A-MEM A-ADR)
1904                 STRING
1905                 NPC))))
1906
1907;Use this to try to find slow ALU bits with a scope.
1908(DEFUN CC-ALU-SPEED-TEST (&OPTIONAL (A-VALUE 0) (M-VALUE 0) (A-REG 2) (M-REG 30))
1909  (PROG (CH FROB-M)
1910        (CC-STOP-MACH)
1911        (CC-EXECUTE (W-C-MEM 100)
1912            CONS-IR-SPARE-BIT 1         ;for scope trigger
1913            CONS-IR-OP CONS-OP-JUMP
1914            CONS-IR-A-SRC A-REG
1915            CONS-IR-M-SRC M-REG
1916            CONS-IR-JUMP-COND CONS-JUMP-COND-M=A
1917            CONS-IR-N 1
1918            CONS-IR-JUMP-ADDR 200)
1919        (CC-EXECUTE (W-C-MEM 101) )
1920        (CC-EXECUTE (W-C-MEM 102)
1921            CONS-IR-OP CONS-OP-JUMP
1922            CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
1923            CONS-IR-N 0
1924            CONS-IR-JUMP-ADDR 100)     
1925        (CC-EXECUTE (W-C-MEM 103)
1926  ;         CONS-IR-OP CONS-OP-ALU
1927  ;         CONS-IR-M-SRC 1
1928  ;         CONS-IR-M-MEM-DEST 1
1929  ;         CONS-IR-OB CONS-OB-ALU
1930  ;         CONS-IR-ALUF CONS-ALU-M+1
1931                    )
1932
1933        (CC-EXECUTE (W-C-MEM 200)
1934            CONS-IR-OP CONS-OP-JUMP
1935            CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
1936            CONS-IR-N 0
1937            CONS-IR-JUMP-ADDR 100)
1938        (CC-EXECUTE (W-C-MEM 201)
1939  ;         CONS-IR-OP CONS-OP-ALU
1940  ;         CONS-IR-M-SRC 3
1941  ;         CONS-IR-M-MEM-DEST 3
1942  ;         CONS-IR-OB CONS-OB-ALU
1943  ;         CONS-IR-ALUF CONS-ALU-M+1
1944                    )
1945   L   (CC-WRITE-A-MEM A-REG A-VALUE)
1946       (CC-WRITE-M-MEM M-REG M-VALUE)
1947       (SETQ CH (CC-RUN-LOOP 100))
1948       (COND ((MEMQ CH '(#/a #/A))
1949              (SETQ FROB-M NIL))
1950             ((MEMQ CH '(#/m #/M))
1951              (SETQ FROB-M T)))
1952       (COND (FROB-M
1953               (COND ((= CH #/+) (SETQ M-VALUE (1+ M-VALUE)))
1954                     ((= CH #/) (SETQ M-VALUE (ASH M-VALUE 1)))
1955                     ((= CH #/) (SETQ M-VALUE (ASH M-VALUE -1)))
1956                     ((OR (= CH #/z) (= CH #/Z)) (SETQ M-VALUE 0))))
1957             (T
1958               (COND ((= CH #/+) (SETQ A-VALUE (1+ A-VALUE)))
1959                     ((= CH #/) (SETQ A-VALUE (ASH A-VALUE 1)))
1960                     ((= CH #/) (SETQ A-VALUE (ASH A-VALUE -1)))
1961                     ((OR (= CH #/z) (= CH #/Z)) (SETQ A-VALUE 0)))))
1962       (FORMAT T "~%M-VALUE = ~s, A-VALUE = ~s" M-VALUE A-VALUE)
1963       (GO L)
1964))
1965
1966(DEFUN CC-RUN-LOOP (ADR &AUX CH)
1967  (CC-WRITE-PC ADR)
1968  (CC-NOOP-CLOCK)               ;FIRST INSTRUCTION TO IR
1969  (CC-CLOCK)                    ;CLOCK AGAIN
1970  (SPY-WRITE SPY-CLK 1) ;TAKE OFF
1971  (DO () ((SETQ CH (KBD-TYI-NO-HANG)))
1972    (PROCESS-SLEEP 15.))
1973  (CC-STOP-MACH)
1974  CH)
1975
1976(DEFUN CC-TEST-PC-INCREMENTER NIL
1977  (DOTIMES (B 14.)
1978    (CC-TEST-PC-INCREMENT (1- (LSH 1 B))))
1979  (DOTIMES (B 13.)
1980    (CC-TEST-PC-INCREMENT (- (LSH 1 (1+ B)) 2))))
1981
1982(DEFUN CC-TEST-PC-INCREMENT (VAL)
1983  (CC-WRITE-PC VAL)
1984  (CC-NOOP-DEBUG-CLOCK)
1985  (COND ((NOT (= (CC-READ-PC) (1+ VAL)))
1986         (FORMAT T "~% PC of  ~s incremented to ~s" VAL (CC-READ-PC)))))
1987
1988(DEFUN CC-TEST-USTACK-TO-PC  (N)
1989  (LET ((USP (CC-READ-MICRO-STACK-PTR))
1990        (VAL))
1991    (CC-WRITE-MD N)     ;GET DATA INTO MRD
1992    (CC-EXECUTE (WRITE)
1993              CONS-IR-M-SRC CONS-M-SRC-MD       ;PUSH IT
1994              CONS-IR-ALUF CONS-ALU-SETM
1995              CONS-IR-OB CONS-OB-ALU
1996              CONS-IR-FUNC-DEST CONS-FUNC-DEST-MICRO-STACK-PUSH)
1997    (CC-EXECUTE
1998              CONS-IR-OP CONS-OP-JUMP
1999              CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
2000              CONS-IR-R 1)
2001    (CC-CLOCK)
2002    (SETQ VAL (CC-READ-PC))
2003    (COND ((NOT (= USP (CC-READ-MICRO-STACK-PTR)))
2004           (FORMAT T "~%USP ~S BEFORE PUSH, POP; ~S AFTER"
2005                   USP  (CC-READ-MICRO-STACK-PTR))))
2006    VAL))
2007
2008(DECLARE (SPECIAL SPY-OPC SPY-OPC-CONTROL))
2009
2010(DEFUN CC-TEST-OPC-TRIAL (N &AUX TEM)
2011  (DOTIMES (C 8)
2012    (CC-WRITE-PC (+ N C)))
2013  (DOTIMES (C 8)
2014    (SETQ TEM (SPY-READ SPY-OPC))
2015    (COND ((NOT (= TEM (+ N C)))
2016           (FORMAT T "~%OPC #~D, WROTE ~S READ ~S" C (+ N C) TEM)))
2017    (SPY-WRITE SPY-OPC-CONTROL 2)       ;CLOCK OPCS
2018    (SPY-WRITE SPY-OPC-CONTROL 0)))
2019
2020(DEFUN CC-PRINT-OPCS-LOOP NIL
2021  (DO () (())
2022    (PRINT (SPY-READ SPY-OPC))
2023    (SPY-WRITE SPY-OPC-CONTROL 2)       ;CLOCK OPCS
2024    (SPY-WRITE SPY-OPC-CONTROL 0)))
2025
2026
2027
2028(DEFUN CC-SETUP-DIVIDE-TEST ()
2029;;; Load C-MEM with divide routine...
2030;;; Divide two numbers.  This routine taken from UCADR 108.
2031;;; Dividend in 22, divisor in 23 (same values as M-1 and M-2 for randomness).
2032;;; Quotient In Q-R, remainder 22.
2033;;; Clobbers 1000@A.  Zeros 2@M, 2@A
2034  (CC-WRITE-M-MEM 2 0)
2035  (CC-EXECUTE (W-C-MEM 0)        ;HALT . in 0
2036      CONS-IR-OP CONS-OP-JUMP
2037      CONS-IR-MF CONS-MF-HALT
2038      CONS-IR-JUMP-ADDR 0
2039      CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
2040      CONS-IR-N 1)
2041  (CC-EXECUTE (W-C-MEM 6))      ;a couple of no-ops to get started by
2042  (CC-EXECUTE (W-C-MEM 7))
2043  (CC-EXECUTE (W-C-MEM 10)      ;(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO DIV1)
2044      CONS-IR-OP CONS-OP-JUMP
2045      CONS-IR-M-SRC 22
2046      CONS-IR-A-SRC 2
2047      CONS-IR-JUMP-ADDR 13
2048      CONS-IR-JUMP-COND CONS-JUMP-COND-M>=A
2049      CONS-IR-N 0)
2050  (CC-EXECUTE (W-C-MEM 11)      ; ((A-TEM1 Q-R) M-1)
2051      CONS-IR-M-SRC 22
2052      CONS-IR-A-MEM-DEST (+ CONS-A-MEM-DEST-INDICATOR 1000)
2053      CONS-IR-OB CONS-OB-ALU
2054      CONS-IR-ALUF CONS-ALU-SETM
2055      CONS-IR-Q CONS-Q-LOAD)
2056  (CC-EXECUTE (W-C-MEM 12)      ;((Q-R) SUB M-ZERO A-TEM1)
2057      CONS-IR-M-SRC 2
2058      CONS-IR-A-SRC 1000
2059      CONS-IR-OB CONS-OB-ALU
2060      CONS-IR-ALUF CONS-ALU-SUB
2061      CONS-IR-Q CONS-Q-LOAD)
2062  (CC-EXECUTE (W-C-MEM 13)      ;DIV1   ((M-1) DIVIDE-FIRST-STEP M-ZERO A-2)
2063      CONS-IR-M-SRC 2
2064      CONS-IR-A-SRC 23
2065      CONS-IR-OB CONS-OB-ALU-LEFT-1
2066      CONS-IR-M-MEM-DEST 22
2067      CONS-IR-ALUF CONS-ALU-DFSTEP
2068      CONS-IR-Q CONS-Q-LEFT)
2069  (CC-EXECUTE (W-C-MEM 14)      ;DIV1A  (JUMP-IF-BIT-SET (BYTE-FIELD 1 0) Q-R DIVIDE-BY-ZERO)
2070      CONS-IR-OP CONS-OP-JUMP
2071      CONS-IR-M-SRC CONS-M-SRC-Q
2072      CONS-IR-JUMP-COND 0       ;test bit 0
2073      CONS-IR-JUMP-ADDR 0
2074      CONS-IR-P 1
2075      CONS-IR-N 1)
2076  (DOTIMES (C 31.)              ;((M-1) DIVIDE-STEP M-1 A-2)
2077    (CC-EXECUTE (W-C-MEM (+ C 15))
2078      CONS-IR-M-SRC 22
2079      CONS-IR-A-SRC 23
2080      CONS-IR-OB CONS-OB-ALU-LEFT-1
2081      CONS-IR-M-MEM-DEST 22
2082      CONS-IR-ALUF CONS-ALU-DSTEP
2083      CONS-IR-Q CONS-Q-LEFT))
2084  (CC-EXECUTE (W-C-MEM (+ 15 31.))      ;((M-1) DIVIDE-LAST-STEP M-1 A-2)
2085      CONS-IR-M-SRC 22
2086      CONS-IR-A-SRC 23
2087      CONS-IR-OB CONS-OB-ALU
2088      CONS-IR-M-MEM-DEST 22
2089      CONS-IR-ALUF CONS-ALU-DSTEP
2090      CONS-IR-Q CONS-Q-LEFT)
2091  (CC-EXECUTE (W-C-MEM (+ 16 31.))      ;(JUMP-LESS-OR-EQUAL-XCT-NEXT M-ZERO A-TEM1 DIV2)
2092      CONS-IR-OP CONS-OP-JUMP
2093      CONS-IR-M-SRC 2
2094      CONS-IR-A-SRC 1000
2095      CONS-IR-JUMP-ADDR (+ 3 16 31.)
2096      CONS-IR-JUMP-COND CONS-JUMP-COND-M<=A
2097      CONS-IR-N 0)
2098  (CC-EXECUTE (W-C-MEM (+ 17 31.))      ;((M-1) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2)
2099      CONS-IR-M-SRC 22
2100      CONS-IR-A-SRC 23
2101      CONS-IR-OB CONS-OB-ALU
2102      CONS-IR-M-MEM-DEST 22
2103      CONS-IR-ALUF CONS-ALU-RSTEP)
2104  (CC-EXECUTE (W-C-MEM (+ 20 31.))      ;((M-1) SUB M-ZERO A-1)
2105      CONS-IR-M-SRC 2
2106      CONS-IR-A-SRC 22
2107      CONS-IR-OB CONS-OB-ALU
2108      CONS-IR-M-MEM-DEST 22
2109      CONS-IR-ALUF CONS-ALU-SUB)
2110  (CC-EXECUTE (W-C-MEM (+ 21 31.))      ;DIV2   ((A-TEM1) XOR M-2 A-TEM1)
2111      CONS-IR-M-SRC 23
2112      CONS-IR-A-SRC 1000
2113      CONS-IR-OB CONS-OB-ALU
2114      CONS-IR-A-MEM-DEST (+ CONS-A-MEM-DEST-INDICATOR 1000)
2115      CONS-IR-ALUF CONS-ALU-XOR)
2116  (CC-EXECUTE (W-C-MEM (+ 22 31.))      ;(POPJ-LESS-OR-EQUAL M-ZERO A-TEM1)
2117      CONS-IR-OP CONS-OP-JUMP
2118      CONS-IR-M-SRC 2
2119      CONS-IR-A-SRC 1000
2120      CONS-IR-JUMP-COND CONS-JUMP-COND-M<=A
2121      CONS-IR-R 1
2122      CONS-IR-N 1)
2123  (CC-EXECUTE (W-C-MEM (+ 23 31.))      ;(POPJ-AFTER-NEXT (A-TEM1) Q-R)
2124      CONS-IR-POPJ 1
2125      CONS-IR-M-SRC CONS-M-SRC-Q
2126      CONS-IR-A-MEM-DEST (+ CONS-A-MEM-DEST-INDICATOR 1000)
2127      CONS-IR-OB CONS-OB-ALU
2128      CONS-IR-ALUF CONS-ALU-SETM)
2129  (CC-EXECUTE (W-C-MEM (+ 24 31.))      ;((Q-R) SUB M-ZERO A-TEM1)
2130      CONS-IR-M-SRC 2
2131      CONS-IR-A-SRC 1000
2132      CONS-IR-OB CONS-OB-ALU
2133      CONS-IR-ALUF CONS-ALU-SUB
2134      CONS-IR-Q CONS-Q-LOAD)
2135  ;calling routine loop
2136  ;1000@a TEM,  1001@A dividend 1002@a divisor 1003@a correct remainder
2137  ;1@M counts errors.
2138  (CC-EXECUTE (W-C-MEM 100)
2139      CONS-IR-A-SRC 1001
2140      CONS-IR-OB CONS-OB-ALU
2141      CONS-IR-M-MEM-DEST 22
2142      CONS-IR-ALUF CONS-ALU-SETA)
2143  (CC-EXECUTE (W-C-MEM 101)
2144      CONS-IR-A-SRC 1002
2145      CONS-IR-OB CONS-OB-ALU
2146      CONS-IR-M-MEM-DEST 23
2147      CONS-IR-ALUF CONS-ALU-SETA)
2148  (CC-EXECUTE (W-C-MEM 102)
2149      CONS-IR-OP CONS-OP-JUMP
2150      CONS-IR-JUMP-ADDR 10
2151      CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
2152      CONS-IR-P 1
2153      CONS-IR-N 1)
2154  (CC-EXECUTE (W-C-MEM 103)
2155      CONS-IR-STAT-BIT 1
2156      CONS-IR-OP CONS-OP-JUMP
2157      CONS-IR-JUMP-ADDR 100
2158      CONS-IR-M-SRC 22
2159      CONS-IR-A-SRC 1003
2160      CONS-IR-JUMP-COND CONS-JUMP-COND-M=A
2161      CONS-IR-N 1)
2162  (CC-EXECUTE (W-C-MEM 104)
2163      CONS-IR-OP CONS-OP-JUMP
2164      CONS-IR-JUMP-ADDR 100
2165      CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
2166      CONS-IR-N 0)
2167  (CC-EXECUTE (W-C-MEM 105)
2168      CONS-IR-M-SRC 1
2169      CONS-IR-OB CONS-OB-ALU
2170      CONS-IR-M-MEM-DEST 1
2171      CONS-IR-ALUF CONS-ALU-M+1)
2172 )
2173
2174
2175;first arg of NIL says use values in machine.
2176(DEFUN CC-DIVIDE-TEST-LOOP (&OPTIONAL (DIVIDEND (RANDOM 37777777))
2177                            (DIVISOR (RANDOM 37777777)))
2178  (LET ((REM (\ DIVIDEND DIVISOR)))
2179    (CC-WRITE-M-MEM 1 0)                        ;error count
2180    (IF (NUMBERP DIVIDEND)
2181        (PROGN (CC-WRITE-A-MEM 1001 DIVIDEND)
2182               (CC-WRITE-A-MEM 1002 DIVISOR)
2183               (CC-WRITE-A-MEM 1003 REM)))
2184    (CC-WRITE-STAT-COUNTER -40000.) ;times around loop
2185    (CC-RUN-TEST-LOOP 100)
2186    (CC-READ-M-MEM 1))
2187)
2188
2189(DEFUN CC-DIVIDE-TEST-LOOP-STATE NIL
2190  (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002)))
2191
2192(DEFUN CC-DIVIDE-RESTORE-STATE (S)
2193  (CC-SETUP-DIVIDE-TEST)
2194  (APPLY (FUNCTION CC-DIVIDE-TEST-LOOP) S))
2195
2196(DEFUN CC-DIVIDE-TEST ()
2197  (DO ((TEM)) (())
2198    (IF (NOT (ZEROP (SETQ TEM (CC-DIVIDE-TEST-LOOP))))
2199        (RETURN TEM))))
2200
2201
2202
2203;use this if divide works at ultra slow speed and fails at normal speed.  Args
2204; that fail should already be loaded as per above test loop.
2205;Running at ultra slow speed, this builds a table output-bus versus PC.
2206;Then, running at normal speed, it samples machine and tries to find the
2207;lowest PC where output bus has wrong thing.
2208(DEFUN CC-DIVIDE-DIAGNOSE ()
2209  (PROG (HIST PC OBUS INST TEM LOWEST-PC LOWEST-PC-OBUS GOOD-COMPARISONS BAD-COMPARISONS)
2210        (CC-SET-SPEED 0)
2211        (CC-COLON-START 100)
2212        (DOTIMES (C 1000)
2213          (CC-STOP-MACH)
2214          (SETQ PC (CC-READ-PC) OBUS (CC-READ-OBUS) INST (CC-READ-IR))
2215          (IF (NOT (= (LDB CONS-IR-OP INST) CONS-OP-JUMP))
2216              (IF (SETQ TEM (ASSQ PC HIST))
2217                  (IF (NOT (= (CDR TEM) OBUS))
2218                      (PROGN (FORMAT T "~%Multiple values observed at PC ~S, ~S ~S "
2219                                     PC OBUS (CDR TEM))
2220                             (CC-PRINT-BITS (LOGXOR OBUS (CDR TEM)))))
2221                  (SETQ HIST (CONS (CONS PC OBUS) HIST))))
2222          (SPY-WRITE SPY-CLK 1))        ;continue
2223        (CC-STOP-MACH)
2224        (CC-SET-SPEED 2)        ;normal
2225        (SPY-WRITE SPY-CLK 1)
2226        (SETQ GOOD-COMPARISONS 0 BAD-COMPARISONS 0)
2227        (DOTIMES (C 1000)
2228          (CC-STOP-MACH)
2229          (SETQ PC (CC-READ-PC) OBUS (CC-READ-OBUS) INST (CC-READ-IR))
2230          (IF (NOT (= (LDB CONS-IR-OP INST) CONS-OP-JUMP))
2231              (IF (SETQ TEM (ASSQ PC HIST))
2232                  (IF (NOT (= OBUS (CDR TEM)))
2233                      (PROGN (SETQ BAD-COMPARISONS (1+ BAD-COMPARISONS))
2234                             (IF (OR (NULL LOWEST-PC)
2235                                     (< PC LOWEST-PC))
2236                                 (SETQ LOWEST-PC PC LOWEST-PC-OBUS OBUS)))
2237                      (SETQ GOOD-COMPARISONS (1+ GOOD-COMPARISONS)))))
2238          (SPY-WRITE SPY-CLK 1))
2239        (CC-STOP-MACH)
2240        (IF LOWEST-PC
2241            (PROGN (FORMAT T "~%Lowest PC at error ~s, OBUS ~s, should be ~s"
2242                           LOWEST-PC LOWEST-PC-OBUS (CDR (ASSQ LOWEST-PC HIST)))
2243                   (FORMAT T "~%bits wrong ")
2244                   (CC-PRINT-BITS (LOGXOR LOWEST-PC-OBUS (CDR (ASSQ LOWEST-PC HIST))))))
2245        (FORMAT T "~%Length of HIST ~s, good comps ~s, bad comps ~s"
2246                (LENGTH HIST) GOOD-COMPARISONS BAD-COMPARISONS)
2247  ))
2248
Note: See TracBrowser for help on using the repository browser.