;;; CADR ADDRESS TESTS THAT RUN IN THE MACHINE 			-*-LISP-*-

(INCLUDE |LMDOC;.COMPL PRELUD|)
;(DECLARE (EVAL (READ)))
;(PROGN (LOAD '(MACROS > DSK LISPM))
;       (LOAD '(DEFMAC FASL DSK LISPM2))
;       (LOAD '(LMMAC > DSK LISPM2)))

(IF-FOR-MACLISP (DECLARE (EVAL (READ))))
(IF-FOR-MACLISP (DEFUN **STRING** MACRO (X) `',(CADR X)) ;Bubbles in my brain
)

(INCLUDE ((LMCONS)CADMAC >))

(DECLARE (SPECIAL CC-MODE-REG CC-DIAG-TRACE))

(COMMENT TEST LOOP STORERS)

;WRITE A-MEMORY, LC HAS ADDRESS SHIFTED INTO DESTINATION FIELD,
;VMA IS ADDED TO LC EACH TIME AROUND THE LOOP, STOP VIA THE STATISTICS COUNTER,
;MD HAS VALUE TO BE STORED, Q-R GETS ADDED TO MD EACH TIME AROUND THE LOOP.
;TO DO THE ADDITIONS WE NEED SOMETHING IN A-MEM.  WE CAUSE IT TO COME
;IN FROM THE PASS-AROUND PATH SO AS NOT TO TRUST THE MEMORY!
;0:	((OA-REG-LOW) LC)
;1:	((A-MEM) MD STAT-BIT) ;HALT HERE WHEN DONE
;2:	((1777@A) Q-R)
;3:	((MD) ADD MD 1777@A)
;4:	((1777@A) VMA)
;5:	((LC) ADD LC 1777@A)
;6:	(JUMP 0)

;THIS VERSION FILLS IT ALL ALTHOUGH IT COULD HAVE MORE PARAMETERS
;BASHES 0@M AS USUAL
;WRONG VALUE IN 0@A BECAUSE THE CODE BASHES 0@M AS IT RUNS AND A=M
(DEFUN CC-FILL-A-MEM (VALUE VALUE-INC UPWARDS-P)
  (CC-EXECUTE (W-C-MEM 0)
	CONS-IR-M-SRC CONS-M-SRC-LC
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-FUNC-DEST CONS-FUNC-DEST-OA-LOW)
  (CC-EXECUTE (W-C-MEM 1)
	CONS-IR-STAT-BIT 1
	CONS-IR-M-SRC CONS-M-SRC-MD
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-INDICATOR)
  (CC-EXECUTE (W-C-MEM 2)
	CONS-IR-M-SRC CONS-M-SRC-Q
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-1777)
  (CC-EXECUTE (W-C-MEM 3)
	CONS-IR-M-SRC CONS-M-SRC-MD
	CONS-IR-A-SRC 1777
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-ADD
	CONS-IR-FUNC-DEST CONS-FUNC-DEST-MD)
  (CC-EXECUTE (W-C-MEM 4)
	CONS-IR-M-SRC CONS-M-SRC-VMA
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-1777)
  (CC-EXECUTE (W-C-MEM 5)
	CONS-IR-M-SRC CONS-M-SRC-LC
	CONS-IR-A-SRC 1777
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-ADD
	CONS-IR-FUNC-DEST CONS-FUNC-DEST-LC)
  (CC-EXECUTE (W-C-MEM 6)
	CONS-IR-OP CONS-OP-JUMP
	CONS-IR-JUMP-ADDR 0
	CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
	CONS-IR-N 1)
  (CC-EXECUTE (W-C-MEM 7)	;SO HAS GOOD PARITY
	CONS-IR-OP CONS-OP-JUMP)
  (CC-WRITE-STAT-COUNTER -1024.) ;STOP AFTER WRITING 1024. LOCATIONS
  (COND (UPWARDS-P
	 (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC 0)	;FIRST ADDRESS, SHIFTED OVER
	 (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA 1_14.)	;ADDRESS INCREMENT (MAGIC NUMBER)
	 (CC-WRITE-Q VALUE-INC)
	 (CC-WRITE-MD VALUE))
	(T
	 (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC 1777_14.);FIRST ADDRESS, SHIFTED OVER
	 (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA -1_14.)	;ADDRESS INCREMENT (MAGIC NUMBER)
	 (CC-WRITE-Q (- VALUE-INC))
	 (CC-WRITE-MD (+ VALUE (* 2000 VALUE-INC)))))
  (CC-RUN-TEST-LOOP 0))

(DECLARE (SPECIAL SPY-MODE SPY-CLK SPY-FLAG-1) (FIXNUM (SPY-READ FIXNUM)))

(DEFUN CC-RUN-TEST-LOOP (ADR)
  (CC-WRITE-PC ADR)
  (CC-NOOP-CLOCK)		;FIRST INSTRUCTION TO IR
  (CC-CLOCK)			;CLOCK AGAIN
  (SPY-WRITE SPY-MODE (LOGIOR CC-MODE-REG 10))  ;ENABLE STAT HALT
  (SPY-WRITE SPY-CLK 1)	;TAKE OFF
  (DO () ((ZEROP (BOOLE 1 4000 (SPY-READ SPY-FLAG-1))))
    #M (SLEEP 1)
    #Q (PROCESS-SLEEP 15.))         ;AWAIT STAT HALT
  )


;SCAN A-MEMORY, LC HAS ADDRESS SHIFTED INTO SOURCE FIELD,
;VMA IS ADDED TO LC EACH TIME AROUND THE LOOP, STOP VIA THE STATISTICS COUNTER,
;MD HAS VALUE TO BE CHECKED FOR, Q-R GETS ADDED TO MD EACH TIME AROUND THE LOOP.
;TO DO THE ADDITIONS WE NEED SOMETHING IN A-MEM.  WE CAUSE IT TO COME
;IN FROM THE PASS-AROUND PATH SO AS NOT TO TRUST THE MEMORY!
;WE BASH 0@A SINCE IT LOSES ANYWAY.
;HALT BY GOING INTO A LOOP WITH STAT-BIT ON IF COMPARE FAILS, GOOD DATA IN MD,
;BAD DATA IN 0@M.
;0:	((OA-REG-HIGH) LC)
;1:	((0@M) 0@A STAT-BIT) ;HALT HERE WHEN DONE, C(A) TO 0@A, 0@M, L
;2:	(JUMP-NOT-EQUAL MD 0@A 10)
;3:	((0@A) Q-R)
;4:	((MD) ADD MD 0@A)
;5:	((0@A) VMA)
;6:	((LC) ADD LC 0@A)
;7:	(JUMP 0)
;10:	(JUMP 10 STAT-BIT)	;HALT HERE IF ERROR

;SCAN OUT A-MEMORY FROM 2@A THROUGH 1777@A, RETURN A LIST OF MISMATCHES
;IN THE FORM ((ADDR GOOD BAD) ...)
;BASHES 0@M AS USUAL.  0@A IS KNOWN TO BE BAD.
;WRITING INTO CONTROL MEMORY BASHES 1@A, SO WE DON'T SCAN THAT EITHER.
(DEFUN CC-SCAN-A-MEM (VALUE VALUE-INC)
  (CC-EXECUTE (W-C-MEM 0)
	CONS-IR-M-SRC CONS-M-SRC-LC
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-FUNC-DEST CONS-FUNC-DEST-OA-HIGH)
  (CC-EXECUTE (W-C-MEM 1)
	CONS-IR-STAT-BIT 1
	CONS-IR-A-SRC 0
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETA
	CONS-IR-M-MEM-DEST 0)
  (CC-EXECUTE (W-C-MEM 2)
	CONS-IR-OP CONS-OP-JUMP
	CONS-IR-M-SRC CONS-M-SRC-MD
	CONS-IR-A-SRC 0
	CONS-IR-JUMP-ADDR 10
	CONS-IR-JUMP-COND CONS-JUMP-COND-M-NEQ-A
	CONS-IR-N 1)
  (CC-EXECUTE (W-C-MEM 3)
	CONS-IR-M-SRC CONS-M-SRC-Q
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-INDICATOR)
  (CC-EXECUTE (W-C-MEM 4)
	CONS-IR-M-SRC CONS-M-SRC-MD
	CONS-IR-A-SRC 0
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-ADD
	CONS-IR-FUNC-DEST CONS-FUNC-DEST-MD)
  (CC-EXECUTE (W-C-MEM 5)
	CONS-IR-M-SRC CONS-M-SRC-VMA
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-SETM
	CONS-IR-A-MEM-DEST CONS-A-MEM-DEST-INDICATOR)
  (CC-EXECUTE (W-C-MEM 6)
	CONS-IR-M-SRC CONS-M-SRC-LC
	CONS-IR-A-SRC 0
	CONS-IR-OB CONS-OB-ALU
	CONS-IR-ALUF CONS-ALU-ADD
	CONS-IR-FUNC-DEST CONS-FUNC-DEST-LC)
  (CC-EXECUTE (W-C-MEM 7)
	CONS-IR-OP CONS-OP-JUMP
	CONS-IR-JUMP-ADDR 0
	CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
	CONS-IR-N 1)
  (CC-EXECUTE (W-C-MEM 10)
	CONS-IR-OP CONS-OP-JUMP
	CONS-IR-JUMP-ADDR 10
	CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
	CONS-IR-N 1
	CONS-IR-STAT-BIT 1)
  (DO ((ADDRESS 2)	;LOOP REPEATS EACH TIME MACHINE HALTS
       (LOC) (GOOD) (BAD)
       (ERRORS NIL))
      (())
    (DECLARE (FIXNUM ADDRESS))
    (CC-WRITE-STAT-COUNTER (- ADDRESS 1024.))	;NUMBER OF LOCATIONS YET TO SCAN
    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC (LSH ADDRESS 6))	;FIRST ADDRESS, SHIFTED OVER
    (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-VMA 1_6)	;ADDRESS INCREMENT (MAGIC NUMBER)
    (CC-WRITE-Q VALUE-INC)
    (CC-WRITE-MD (+ VALUE (* VALUE-INC ADDRESS)))
    (CC-RUN-TEST-LOOP 0)			;RUN UNTIL DONE OR ERROR
    (AND (= (CC-READ-PC) 3)			;NORMAL HALT, DONE
	 (RETURN (NREVERSE ERRORS)))
    (SETQ ADDRESS (1+ (LSH (CC-READ-M-MEM CONS-M-SRC-LC) -6))  ;NEXT ADDRESS TO DO
	  LOC (1- ADDRESS)
	  GOOD (CC-READ-M-MEM CONS-M-SRC-MD) 
	  BAD (CC-READ-M-MEM 0))
    (AND CC-DIAG-TRACE (PRINT (LIST 'LOC LOC 'GOOD GOOD 'BAD BAD)))
    (SETQ ERRORS (CONS (LIST LOC GOOD BAD) ERRORS))))

(DEFUN CC-ADDRESS-TEST-A-MEM ()
  (DO ((SHIFT 0 (1+ SHIFT))
       (ADDEND (+ 1 (LSH 1 10.) (LSH 1 20.) (LSH 1 30.))
	       (+ ADDEND ADDEND))
       (TEM))
      ((= SHIFT 10.))
    (DECLARE (FIXNUM SHIFT ADDEND))
    (CC-FILL-A-MEM 0 ADDEND T)			;FILL UPWARDS WITH ADDRESS
    (COND ((SETQ TEM (CC-SCAN-A-MEM 0 ADDEND))	;SCAN FOR ERRORS
	   (CC-FILL-A-MEM 0 ADDEND NIL)		;GOT ERROR, FILL DOWNWARDS
	   (CC-ADDRESS-TEST-ANALYZE TEM (CC-SCAN-A-MEM 0 ADDEND) SHIFT NIL))) ;TELL RESULTS
    (CC-FILL-A-MEM -1 (- ADDEND) T)		;FILL UPWARDS WITH COMPLEMENT OF ADDRESS
    (COND ((SETQ TEM (CC-SCAN-A-MEM -1 (- ADDEND)))	;SCAN FOR ERRORS
	   (CC-FILL-A-MEM -1 (- ADDEND) NIL)	;GOT ERROR, FILL DOWNWARDS
	   (CC-ADDRESS-TEST-ANALYZE TEM (CC-SCAN-A-MEM -1 (- ADDEND))
				    SHIFT T)))))	;TELL RESULTS

;THIS COULD BE MUCH HAIRIER
(DEFUN CC-ADDRESS-TEST-ANALYZE (UPWARD-ERRORS DOWNWARD-ERRORS SHIFT COMPLEMENT-P)
  (DO ((L (NCONC UPWARD-ERRORS DOWNWARD-ERRORS) (CDR L))
       (ADDRESS-AND -1)
       (ADDRESS-IOR 0)
       (DATA-BITS-IN-ERROR 0))
      ((NULL L)
       (PRINC "Address AND ") (PRIN1 ADDRESS-AND)
       (PRINC ", address IOR ") (PRIN1 ADDRESS-IOR)
       (PRINC ", data bits in error ") (PRIN1 DATA-BITS-IN-ERROR)
       (TERPRI))
    (DECLARE (FIXNUM ADDRESS-AND ADDRESS-IOR DATA-BITS-IN-ERROR)) ;NOT TESTING C-MEM
    (SETQ ADDRESS-AND (LOGAND (CAAR L) ADDRESS-AND)
	  ADDRESS-IOR (LOGIOR (CAAR L) ADDRESS-IOR)
	  DATA-BITS-IN-ERROR (LOGIOR (LOGXOR (CADAR L) (CADDAR L)) DATA-BITS-IN-ERROR))))

;FAST ADDRESS TEST WRITES ZEROS AND ONES INTO 2 LOCATIONS 
;WHOSE ADDRESSES DIFFER IN 1 BIT, CHECKS FOR INTERFERENCE.
;THIS DETECTS ADDRESS BITS STUCK AT ZERO OR ONE FOR SOME DATA
;BITS, BUT DOES NOT DETECT ADJACENT ADDRESS BITS SHORTED TOGETHER.
(DEFUN CC-FAST-ADDRESS-TEST (MEM-NAME REGADR N-DATA-BITS N-ADDRESS-BITS)
  (DECLARE (FIXNUM REGADR N-DATA-BITS N-ADDRESS-BITS))
  (DO ((N 2 (1- N))
       (PHASE T NIL)
       (ONES (SUB1 #Q (DPB 1 (+ (LSH N-DATA-BITS 6) 1) 0)  #M(EXPT 2 N-DATA-BITS)))
       (ZEROS 0))
      ((= N 0))
    (DO ((BITNO 0 (1+ BITNO))
	 (GOOD1 (COND (PHASE ZEROS) (T ONES)))
	 (GOOD2 (COND (PHASE ONES) (T ZEROS)))
	 (BAD1)
	 (BAD2)
	 (BAD3)
	 (K)
         (CC-SUSPECT-BIT-LIST))
	((= BITNO N-ADDRESS-BITS))
      (SETQ K (+ REGADR (LSH 1 BITNO)))
      (CC-R-D K GOOD2)
      (COND ((NOT (EQUAL (SETQ BAD2 (CC-R-E K)) GOOD2))
	     (PRINC MEM-NAME) (PRINC " loc ") (PRIN1 (- K REGADR))
	     (CC-PRINT-BIT-LIST " fails in data bits "
				(CC-WRONG-BITS-LIST GOOD2 BAD2 N-DATA-BITS))))
      (CC-R-D REGADR GOOD1)			;Deposit in loc 0 second for A & M's sake
      (COND ((NOT (EQUAL (SETQ BAD1 (CC-R-E REGADR)) GOOD1))
	     (PRINC MEM-NAME) (PRINC " loc 0")
	     (CC-PRINT-BIT-LIST " fails in data bits "
				(CC-WRONG-BITS-LIST GOOD1 BAD1 N-DATA-BITS))))
      (COND ((NOT (EQUAL (SETQ BAD3 (CC-R-E K)) GOOD2))
	     (PRINC MEM-NAME) (PRINC " address bit ") (PRIN1-DECIMAL BITNO)
	     (CC-PRINT-BIT-LIST " fails in data bits "
				(CC-WRONG-BITS-LIST GOOD2 BAD3 N-DATA-BITS)))))))

(DEFUN PRIN1-DECIMAL (X)
  (LET ((BASE 10.) (*NOPOINT T))
    (PRIN1 X)))

(DEFUN CC-WRONG-BITS-LIST (GOOD BAD N-DATA-BITS)
  (DO ((BITNO 0 (1+ BITNO))
       (PPSS 0001 (+ 100 PPSS))
       (L NIL))
      ((= BITNO N-DATA-BITS) L)
    (OR (= (LOGLDB PPSS GOOD) (LOGLDB PPSS BAD))
	(SETQ L (CONS BITNO L)))))

;(DEFUN CC-FAST-ADDRESS-TEST (MEM-NAME REGADR N-DATA-BITS N-ADDRESS-BITS)
;NOTE, CAN'T TEST BIT 16 OF D-MEM (R-BIT)
;FOR NOW, ONLY TESTS FIRST 4K OF CONTROL MEMORY
(DEFUN CC-FAST-ADDRESS-TEST-ALL ()
  (MAPC ;'CC-FAST-ADDRESS-TEST
        (FUNCTION (LAMBDA (A B C D) (PRINC A) (TERPRI) (CC-FAST-ADDRESS-TEST A B C D)))
	'(M-MEM A-MEM PDL-BUFFER C-MEM D-MEM SPC FIRST-LEVEL-MAP SECOND-LEVEL-MAP)
	(LIST RAMMO RAAMO RAPBO RACMO RADMO RAUSO RAM1O RAM2O)
	'(32. 32. 32. 48. 16. 19. 5. 24.)
	'(5. 10. 10. 12. 11. 5. 11. 10.))
  T)