Context Navigation

diags.lisp @ 205

Revision 205, 79.3 KB (checked in by rjs, 22 months ago)
Update.

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 ->
205	Unibus -> Xbus -> MD -> A-MEM ->
206	A-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 '\|/
1002	BYTL-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 '\|/
1039	BYTL-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 '\|/
1105	Wrong 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 '\|/
1119	LC=\|)
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 '\|/
1136	Wrong 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 '\|/
1150	LC=\|)
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
1384	AND 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 "
1658	Speed 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 browser.

Download in other formats:

Original Format