;;; CADR Datapath diagnostic			-*-LISP-*-
;;; Fairly simple-minded, at the moment.

(INCLUDE |LMDOC;.COMPL PRELUD|)

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

(INCLUDE ((LMCONS)CADMAC >))

(DECLARE (FIXNUM I J K M N NBITS BITNO REGADR PPSS SHIFT RELAD)
	 (SPECIAL CC-SUSPECT-BIT-LIST CC-DIAG-TRACE CC-TEST-ADR-BARFED))

(SETQ CC-DIAG-TRACE NIL)  ;T PRINTS ALL ERRORS AS THEY OCCUR


;TESTS
(DEFUN CC-TEST-IR ()
  (CC-TEST-DATA-PATH "Unibus -> DEBUG-IR -> IR -> Unibus" RAIR 48.))

(DEFUN CC-TEST-MD ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> MF -> M -> ALU -> Obus" RAMD 32.))

(DEFUN CC-TEST-LC ()
  (CC-WRITE-M-MEM CONS-FUNC-DEST-INT-CNTRL 1_29.)	;SET LC BYTE MODE
  (TERPRI)
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> LC -> MF -> M -> ALU -> Obus" RALC 26.))

(DEFUN CC-TEST-PC ()
  (CC-TEST-DATA-PATH "IR -> PC -> Unibus (via JUMP instr)" RAPC 14.))

(DEFUN CC-TEST-M-MEM-DP ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> M-MEM -> M -> ALU -> Obus" RAMMO 32.))

(DEFUN CC-TEST-A-MEM-DP ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> A-MEM -> ALU -> Obus" RAAMO 32.))

(DEFUN CC-TEST-PDL-DP ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> PDL-Buffer -> M -> ALU -> Obus" RAPBO 32.))

(DEFUN CC-TEST-PP ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> PP -> MF -> M -> ALU -> Obus" RAPP 10.))

(DEFUN CC-TEST-PI ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> PI -> MF -> M -> ALU -> Obus" RAPI 10.))

(DEFUN CC-TEST-Q ()
  (CC-TEST-DATA-PATH "IR -> Serial ALU -> MD -> ALU -> Q -> MF -> M -> ALU -> Obus" RAQ 32.))

(DEFUN CC-TEST-M-MEM-ADR ()
  (CC-TEST-ADR "M-MEM" RAMMO 32. 32. 1))   ;COMMENT, REGADR, WIDTH, # REGISTERS, INITIAL 
			;RELATIVE TEST ADR; M 0 DOESNT WIN SINCE IT GETS CLOBBERED BY 
                                    ;CC-R-D WHEN WRITING THE MD.

(DEFUN CC-TEST-A-MEM-ADR ()
  (CC-TEST-ADR "A-MEM" RAAMO 32. 1024. 1)) ;LIKEWISE, A 0 LOSES.

(DEFUN CC-TEST-PDL-ADR ()
  (CC-TEST-ADR "PDL-BUFFER" RAPBO 32. 1024. 0))


(DEFUN CC-TEST-ADR (MESSAGE REGADR NBITS NREG IRELAD)
 (COND ((<= NBITS 36.)	;FOR SPEED, FIXNUM CASE IS SEPARATE
  (DO ((SHIFT 0 (1+ SHIFT))
       (ONES (1- #M (EXPT 2 NBITS) #Q (DPB 1 (+ (LSH NBITS 6) 0001) 0)))
       (ACTUAL)
       (CC-TEST-ADR-BARFED NIL)
       (ERRORS 0 0))
      ((= SHIFT NBITS))
    (DECLARE (FIXNUM ONES ACTUAL))  ;THIS WONT WIN FOR C-MEM, BUT ITS SO-- SLOW OTHERWISE
    (TERPRI)
    (PRINC '|Shift=|)(PRIN1 SHIFT)
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(CC-R-D (+ REGADR RELAD) (LOGAND ONES (LSH RELAD SHIFT))))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
		       (LOGAND ONES (LSH RELAD SHIFT))))
	       (SETQ ERRORS (1+ ERRORS))
	       (CC-TEST-ADR-BARF MESSAGE RELAD (LOGAND ONES (LSH RELAD SHIFT)) ACTUAL))))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(CC-R-D (+ REGADR RELAD) (LOGAND ONES (LOGXOR -1 (LSH RELAD SHIFT)))))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
		       (LOGAND ONES (LOGXOR -1 (LSH RELAD SHIFT)))))
	       (SETQ ERRORS (1+ ERRORS))
	       (CC-TEST-ADR-BARF MESSAGE RELAD (LOGAND ONES (LOGXOR -1 (LSH RELAD SHIFT)))
				 ACTUAL))))
;IF THERE WERE ERRORS, GO THRU THE OPPOSITE DIRECTION TO ATTEMPT TO DETERMINE
; THE HIGH ADR THAT LOST.
    (COND ((NOT (ZEROP ERRORS))
	   (PRINC "SCANNING DOWN, SAME PARAMETERS")
	   (TERPRI)
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
	       (CC-R-D (+ REGADR RELAD) (LOGAND ONES (LSH RELAD SHIFT))))
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
	       (COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
			      (LOGAND ONES (LSH RELAD SHIFT))))
		      (SETQ ERRORS (1+ ERRORS))
		      (CC-TEST-ADR-BARF MESSAGE RELAD
					(LOGAND ONES (LSH RELAD SHIFT)) ACTUAL))))
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
	       (CC-R-D (+ REGADR RELAD) (LOGAND ONES (LOGXOR -1 (LSH RELAD SHIFT)))))
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD NREG)
	       (COND ((NOT (= (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
			      (LOGAND ONES (LOGXOR -1 (LSH RELAD SHIFT)))))
		      (SETQ ERRORS (1+ ERRORS))
		      (CC-TEST-ADR-BARF MESSAGE RELAD
					(LOGAND ONES (LOGXOR -1 (LSH RELAD SHIFT)))
					ACTUAL))))
	   (TERPRI)))
))
 (T  ;NON-FIXNUM CASE
  (DO ((SHIFT 0 (1+ SHIFT))
       (SHIFTMPY 1 (PLUS SHIFTMPY SHIFTMPY))
       (ONES (DIFFERENCE #M (EXPT 2 NBITS) #Q (DPB 1 (+ (LSH NBITS 6) 0001) 0) 1))
       (ACTUAL)
       (CC-TEST-ADR-BARFED NIL)
       (ERRORS 0 0))
      ((= SHIFT NBITS))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(CC-R-D (+ REGADR RELAD) (TIMES RELAD SHIFTMPY)))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
			   (TIMES RELAD SHIFTMPY)))
	       (SETQ ERRORS (1+ ERRORS))
	       (CC-TEST-ADR-BARF MESSAGE RELAD (TIMES RELAD SHIFTMPY) ACTUAL))))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(CC-R-D (+ REGADR RELAD) (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
    (DO RELAD IRELAD (1+ RELAD) (= RELAD NREG)
	(COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
			   (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
	       (SETQ ERRORS (1+ ERRORS))
	       (CC-TEST-ADR-BARF MESSAGE RELAD (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))
				 ACTUAL))))
;IF THERE WERE ERRORS, GO THRU THE OPPOSITE DIRECTION TO ATTEMPT TO DETERMINE
; THE HIGH ADR THAT LOST.
    (COND ((NOT (ZEROP ERRORS))
	   (PRINC "SCANNING DOWN, SAME PARAMETERS")
	   (TERPRI)
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
	       (CC-R-D (+ REGADR RELAD) (TIMES RELAD SHIFTMPY)))
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
	       (COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
				  (TIMES RELAD SHIFTMPY)))
		      (SETQ ERRORS (1+ ERRORS))
		      (CC-TEST-ADR-BARF MESSAGE RELAD (TIMES RELAD SHIFTMPY) ACTUAL))))
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD IRELAD)
	       (CC-R-D (+ REGADR RELAD) (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
	   (DO RELAD (1- NREG) (1- RELAD) (< RELAD NREG)
	       (COND ((NOT (EQUAL (SETQ ACTUAL (CC-R-E (+ REGADR RELAD)))
				  (DIFFERENCE ONES (TIMES RELAD SHIFTMPY))))
		      (SETQ ERRORS (1+ ERRORS))
		      (CC-TEST-ADR-BARF MESSAGE RELAD
					(DIFFERENCE ONES (TIMES RELAD SHIFTMPY))
					ACTUAL))))
	   (TERPRI)))
))))

(DEFUN CC-TEST-ADR-BARF (MESSAGE RELAD GOOD BAD)
  (COND ((NOT CC-TEST-ADR-BARFED)
	 (SETQ CC-TEST-ADR-BARFED T)
	 (PRINC "Error while address-testing ") (PRINC MESSAGE) (TERPRI)))
  (PRINC "Rel addr ") (PRIN1 RELAD)
  (PRINC " wrote ") (PRIN1 GOOD)
  (PRINC " read ") (PRIN1  BAD) (TERPRI))

(DEFUN CC-WRITE-AND-READ (REGADR DATA)
  (CC-R-D REGADR DATA)
  (LET ((ACTUAL (CC-R-E REGADR)))
    (COND ((AND CC-DIAG-TRACE (NOT (EQUAL ACTUAL DATA)))
	   (PRINC "Reg addr ") (PRIN1 REGADR)
	   (PRINC " wrote ") (PRIN1 DATA)
	   (PRINC " read ") (PRIN1 ACTUAL) (TERPRI)))
    ACTUAL))

;RETURNS T IF IT WORKS, PRINTS MESSAGE AND RETURNS NIL IF IT IS BUSTED.
(DEFUN CC-TEST-DATA-PATH (MESSAGE REGADR NBITS)
  (LET ((TEM)
	(CC-SUSPECT-BIT-LIST NIL)
	(ZEROS 0)
	(ONES (SUB1 #M (EXPT 2 NBITS) #Q (DPB 1 (+ (LSH NBITS 6) 0001) 0))))
    (COND ((EQUAL (SETQ TEM (CC-WRITE-AND-READ REGADR ZEROS))
		  (CC-WRITE-AND-READ REGADR ONES))
	   (CC-BARF-ABOUT-DATA-PATH MESSAGE REGADR)
	   (PRINC "Can't affect it, erroneous value is ")
	   (PRIN1 TEM)
	   (TERPRI)
	   NIL)
	  (T (LET ((BITS-NOT-ONE (CC-TEST-DATA-PATH-FLOATING-BITS REGADR NBITS ZEROS))
		   (BITS-NOT-ZERO (CC-TEST-DATA-PATH-FLOATING-BITS REGADR NBITS ONES)))
	       (COND ((AND (NULL BITS-NOT-ONE) (NULL BITS-NOT-ZERO)	;NO ERROR
			   (NULL CC-SUSPECT-BIT-LIST))
		      T)
		     (T
		      (LET ((ERRONEOUS-BITS	;BITS THAT LOSE, TEST FOR SHORTING
			   	(NUMERIC-LIST-UNION BITS-NOT-ONE BITS-NOT-ZERO)))
			(LET ((STUCK-AT-ZERO
			        (NUMERIC-LIST-DIFFERENCE BITS-NOT-ONE BITS-NOT-ZERO))
			      (STUCK-AT-ONE
			        (NUMERIC-LIST-DIFFERENCE BITS-NOT-ZERO BITS-NOT-ONE)))
			  (CC-BARF-ABOUT-DATA-PATH MESSAGE REGADR)
			  (CC-PRINT-BIT-LIST "Bits stuck at zero: " STUCK-AT-ZERO)
			  (CC-PRINT-BIT-LIST "Bits stuck at one: " STUCK-AT-ONE)
			  (AND (= (LENGTH ERRONEOUS-BITS) 2)  ;MAYBE THEY'RE SHORTED TOGETHER
			       (CC-TEST-DATA-PATH-SHORTED-BIT REGADR NBITS
							      (CAR ERRONEOUS-BITS)))
			  NIL)
			(CC-PRINT-BIT-LIST "The following bits are also suspected of being losers:"
					   CC-SUSPECT-BIT-LIST)

))))))))

;RETURN LIST OF BIT NUMBERS WHICH WON'T SET DIFFERENT FROM THE OTHERS.
;ALSO SETS CC-SUSPECT-BIT-LIST TO BITS WHICH ARE NOTICED TO
;BE LOSING WHILE TESTING DIFFERENT BITS.
;NOTE THE NEED TO DO BIGNUM ARITHMETIC.
(DEFUN CC-TEST-DATA-PATH-FLOATING-BITS (REGADR NBITS BACKGROUND)
  ;FIRST, DETERMINE SENSE OF BIT LOOKING FOR
  (LET ((M (COND ((ZEROP BACKGROUND) 1) (T -1)))
	(K (COND ((ZEROP BACKGROUND) 1) (T 0))))
  ;NOW, FLOAT BIT THROUGH WORD, WRITE AND READ, CHECK THAT BIT ALONE FOR CORRECTNESS
    (DO ((BITNO 0 (1+ BITNO))
	 (BITMASK M (PLUS BITMASK BITMASK))
	 (READBACK)
	 (R NIL))
        ((>= BITNO NBITS) R)
      (SETQ READBACK (CC-WRITE-AND-READ REGADR (PLUS BACKGROUND BITMASK)))
      (DO ((J 0 (1+ J))
	   (PPSS 0001 (+ PPSS 100)))
	  ((>= J NBITS))
        (COND ((= J BITNO)
	       (OR (= (LOGLDB PPSS READBACK) K)
		   (SETQ R (CONS BITNO R))))
	      (T  ;NOT THE BIT WE'RE TESTING, BUT CHECK IT ANYWAY
	       (AND (= (LOGLDB PPSS READBACK) K)
		    (CC-FINGER-SUSPECT-BIT J))))))))

(DEFUN CC-FINGER-SUSPECT-BIT (BITNO)
  (OR (NUMERIC-LIST-MEMQ BITNO CC-SUSPECT-BIT-LIST)
      (SETQ CC-SUSPECT-BIT-LIST (CONS BITNO CC-SUSPECT-BIT-LIST))))

;GIVEN A BIT WHICH FAILS, TRY TO PROVE IT IS SHORTED TO SOME OTHER BIT.
;PRINT OUT THE RESULTS AND OUGHT TO REMOVE FROM SUSPECT LIST.			*******
;NOTE THAT FOR NON-COMPLEMENTED TRI-STATE DATA PATHS, 1 SHORTED TO 0 GIVES 0,
;THUS IN THE NORMAL TEST SHORTED BITS LOOK STUCK AT ZERO.
;THIS ONLY TESTS WITH ONES.
(DEFUN CC-TEST-DATA-PATH-SHORTED-BIT (REGADR NBITS BITNO)
  (DO ((MASK1 #M (EXPT 2 BITNO) #Q (DPB 1 (+ (LSH BITNO 6) 0001) 0))
       (I 0 (1+ I))
       (MASK2 1 (PLUS MASK2 MASK2))
       (TEM)
       (BASE 10.)
       (*NOPOINT T)
       (LOSING-BITS NIL))
      ((>= I NBITS)
       (COND ((= (LENGTH LOSING-BITS) 1)
	      (PRINC "Bit ") (PRIN1 BITNO) (PRINC " is shorted to bit ")
	      (PRIN1 (CAR LOSING-BITS)) (TERPRI))
	     (T
	      (PRINC "Bit ") (PRIN1 BITNO) (PRINC " has problems, can't isolate.")
	      (TERPRI)
	      (CC-PRINT-BIT-LIST "Seems as if shorted to bits " LOSING-BITS))))
    (COND ((= I BITNO))	;OF COURSE IT'S SHORTED TO ITSELF!
	  ((EQUAL (SETQ TEM (PLUS MASK1 MASK2))
		  (CC-WRITE-AND-READ REGADR TEM))
	   (SETQ LOSING-BITS (CONS I LOSING-BITS))))))

(DEFUN CC-BARF-ABOUT-DATA-PATH (MESSAGE REGADR)
  (TERPRI)
  (PRINC "Testing register address ")
  (PRIN1 REGADR)
  (PRINC ",")
  (TERPRI)
  (PRINC " data path is ")
  (PRINC MESSAGE)
  (TERPRI))

(DEFUN CC-PRINT-BIT-LIST (MESSAGE BITLIST)
  (COND (BITLIST
	 (PRINC MESSAGE)
	 (DO ((L (SORT BITLIST 'LESSP) (CDR L))
	      (COMMA NIL T)
	      (LASTVALUE -2 (CAR L))
	      (RANGE-END NIL)
	      (RANGE-START)
	      (BASE 10.)
	      (*NOPOINT T))
	     ((NULL L)
	      (AND RANGE-END
		   (COND ((= (1+ RANGE-START) RANGE-END)
			  (PRINC ", ") (PRIN1 RANGE-END))
			 (T (PRINC "-") (PRIN1 RANGE-END)))))
	   (COND ((= (CAR L) (1+ LASTVALUE))
		  (OR RANGE-END (SETQ RANGE-START LASTVALUE))
		  (SETQ RANGE-END (CAR L)))
		 (T
		  (AND RANGE-END
		       (COND ((= (1+ RANGE-START) RANGE-END)
			      (PRINC ", ") (PRIN1 RANGE-END))
			     (T (PRINC "-") (PRIN1 RANGE-END))))
		  (SETQ RANGE-END NIL)
		  (AND COMMA (PRINC ", "))
		  (PRIN1 (CAR L)))))
	 (SETQ CC-SUSPECT-BIT-LIST
	       (NUMERIC-LIST-DIFFERENCE CC-SUSPECT-BIT-LIST BITLIST))
	 (TERPRI))))

(DEFUN NUMERIC-LIST-MEMQ (N L)
  (DO ((L L (CDR L)))
      ((NULL L) NIL)
    (AND (= (CAR L) N)
	 (RETURN L))))

(DEFUN NUMERIC-LIST-UNION (L1 L2)
  (DO ((L L1 (CDR L))
       (R L2))
      ((NULL L) R)
    (OR (NUMERIC-LIST-MEMQ (CAR L) R)
	(SETQ R (CONS (CAR L) R)))))

(DEFUN NUMERIC-LIST-INTERSECTION (L1 L2)
  (DO ((L L1 (CDR L))
       (R NIL))
      ((NULL L) R)
    (AND (NUMERIC-LIST-MEMQ (CAR L) L2)
	 (SETQ R (CONS (CAR L) R)))))

(DEFUN NUMERIC-LIST-DIFFERENCE (L1 L2)
  (DO ((L L1 (CDR L))
       (R NIL))
      ((NULL L) R)
    (OR (NUMERIC-LIST-MEMQ (CAR L) L2)
	(SETQ R (CONS (CAR L) R)))))