;
;  VMIC 486PC interface to TDC input card
;  VERSION 5 with HOTLINK receiver & testing for all tokens
;     and up to 6 INRX FPGA's
;  Proto Output interface
;
;  fixed bug with memory read upper nibble (bits 12-15) floating
;
(load (string-append s88path "modulo.ss"))
(load (string-append s88path "bool.so"))
(load (string-append s88path "ffix.ss"))

(define vmic-setup
  (lambda ()
    (outp #x140 #x0a) ; set VME port active
    ;
    ; set A32-A24 to 0 and AM to 29
    ;
    (outp16 #x142 #x29)))


(vmic-setup)

(define vme-base (- #xE000 #x10000))

(define vme-write-byte
  (lambda (a v)
    (poke vme-base a v)))

(define vme-read-byte
  (lambda (a)
    (peek vme-base a)))

(define vme-write-word
  (lambda (a v)
    (if (not (integer? v))
	(error 'vme-write " bad value ~s" v)
	#t)
    (let*  ((d1 (remainder v 256))
	    (d0 (quotient v 256)))
      (if (fixnum? a)
	  #t
	  (error 'vme-write " bad address ~s " a))
      (if (> d0 255)
	  (error 'vme-write " bad value ~s" v)
	  #t)
      (poke vme-base (+ a 1) d1)  ; load byte 1
      (poke vme-base (+ a 0) d0)  ; load byte 0
      #t)))

(define vme-read-word
  (lambda (a)
    (if (fixnum? a)
	#t
	(error 'vme-read " bad address ~s " a))
    (let ((b0 (peek vme-base (+ a 0)))
	  (b1 (peek vme-base (+ a 1))))
      (+ (* 256 b0) b1))))
 
;
;  display function
;
(define hex-byte
  (lambda (v)
    (let ((s (number->string (+ #x100 v) 16)))
      (string-set! s 0 #\space)
      s)))

(define hex-word
  (lambda (v)
    (let ((s (number->string (+ #x10000 v) 16)))
      (string-set! s 0 #\space)
      s)))

(define hex-top-byte
  (lambda (v)
    (let ((s (number->string (+ #x100 (quotient v #x1000000)) 16)))
      (string-set! s 0 #\space)
      s)))

(define hex-24
  (lambda (v)
    (let ((s (number->string (+ #x1000000 (remainder v #x1000000)) 16)))
      (string-set! s 0 #\space)
      s)))

(define hex-long
  (lambda (v)
    (let ((s (number->string (+ #x100000000 v) 16)))
      (string-set! s 0 #\space)
      s)))

;
; TDC INRX readback tests
;

(define vme-read-word-test
  (lambda (a)
    (if (fixnum? a)
	#t
	(error 'vme-read-test " bad address ~s " a))
    (let ((b0 (peek vme-base (+ a 0)))
	  (b1 (peek vme-base (+ a 1))))
      (if (zero? (band b0 #xf0))
	  (+ (* 256 b0) b1)
	  (begin
	    (writeln "upper bits one")
	    (+ (* 256 (band #xf b0)) b1))))))

(define rbt
  (lambda ()
    (rbt-loop 0 1 #xfff #t)))

(define rbt-loop
  (lambda (a v x f)
    (if (= v 4096) f
	(let ((w (bxor x v)))
	  (vme-write-word a w)
	  (let ((r (vme-read-word-test a)))
	    (if (= w r)
		(begin
		  (rbt-loop a (* 2 v) x f))
		(begin
		  (writeln "rbt error v"v"w"w"r"r)
		  (rbt-loop a (* 2 v) x #f))))))))
;
;
;  INPUT card TDC buffer functions
;

(define channel 0) ; sets the INRX channel number from 0 to 5

(define buffer-names 
  '("test token " "DAQ  token " "L2   token " "RX   token "
    "test count " "DAQ  count " "L2   count " "RX   count "
    "buffer     " "error      " "datacnt    " "ctrlcnt    "))

(define statec
  (lambda (c)
    (set! channel c)
    (state)))

(define state
  (lambda ()
    (writeln "INPUT CHANNEL" channel)	     
    (state-loop buffer-names 0 (* channel 32))))

(define state-loop
  (lambda (n i o)
    (if (null? n)
	(void)
	(begin
	  (writeln (car n) (vme-read-word (+ i o)))
	  (state-loop (cdr n) (+ 2 i) o)))))

(define state0
  (lambda ()
    (writeln "test token " (vme-read-word 0))    
    (writeln "DAQ  token " (vme-read-word 2))    
    (writeln "L2   token " (vme-read-word 4))    
    (writeln "RX   token " (vme-read-word 6))    
    (writeln "test count " (vme-read-word 8))    
    (writeln "DAQ  count " (vme-read-word 10))    
    (writeln "L2   count " (vme-read-word 12))    
    (writeln "RX   count " (vme-read-word 14))    
    (writeln "buffer     " (vme-read-word 16))
    (writeln "error      " (vme-read-word 18))
    (writeln "datacnt    " (vme-read-word 20))
    (writeln "crtlcnt    " (vme-read-word 22))
    ))

;
;  OUTPUT card status
;


(define score-base #x1000)
(define rx-base #x800)

(define score
  (lambda ()
    (writeln "G bus 11:00   #x" (number->string (vme-read-word (+ score-base #x20)) 16))    
    (writeln "G bus 23:12   #x" (number->string (vme-read-word (+ score-base #x22)) 16))    
    (writeln "G bus 35:24   #x" (number->string (vme-read-word (+ score-base #x24)) 16))    
    (writeln "readback      #x" (number->string (vme-read-word (+ score-base #x26)) 16))    

    (writeln "FIFO stat/TW  #x" (number->string (vme-read-word (+ score-base #x40)) 16))    
    (writeln "token number  #x" (number->string (vme-read-word (+ score-base #x42)) 16))
    (writeln "FIFO TT write #x" (number->string (vme-read-word (+ score-base #x44)) 16))    
    (writeln "FIFO TW write #x" (number->string (vme-read-word (+ score-base #x46)) 16))    

    (writeln "FIFO L2 token #x" (number->string (vme-read-word (+ score-base #x48)) 16))    
    (writeln "FIFO DAQ tokn #x" (number->string (vme-read-word (+ score-base #x4a)) 16))    
    (writeln "FIFO L2 tword #x" (number->string (vme-read-word (+ score-base #x4c)) 16))    
    (writeln "FIFO DAQ twrd #x" (number->string (vme-read-word (+ score-base #x4e)) 16))    

    (writeln "L2 Score Board#x" (number->string (vme-read-word (+ score-base #x50)) 16))    

    (writeln "L2 write count  " (vme-read-word (+ score-base #x60)))    
    (writeln "DAQ write count " (vme-read-word (+ score-base #x62)))    
    (writeln "L2 read count   " (vme-read-word (+ score-base #x64)))    
    (writeln "DAQ read count  " (vme-read-word (+ score-base #x66)))
    ))

(define glinkrx
  (lambda ()
    (writeln "Glink RX data #x" (number->string (vme-read-word (+ rx-base #x28)) 16))    
    (writeln "RX DAV count    " (vme-read-word (+ rx-base #x2c)))    
    (writeln "RX CAV count    " (vme-read-word (+ rx-base #x2e)))
    
    (writeln "Glink RX FIFO #x" (number->string (vme-read-word (+ rx-base #x30)) 16))    
    (writeln "Glink RX STAT #x" (number->string (vme-read-word (+ rx-base #x32)) 16))    
    (writeln "RX FIFO write   " (vme-read-word (+ rx-base #x34)))    
    (writeln "RX FIFO read    " (vme-read-word (+ rx-base #x36)))    
    ))

(define glinkfifo
  (lambda ()
    (if (= (vme-read-word (+ rx-base #x34))
	   (vme-read-word (+ rx-base #x36)))
	#t
	(let* ((stat (vme-read-word (+ rx-base #x32)))
	       (data (vme-read-word (+ rx-base #x30)))
	       (datastr (number->string (+ #x10000 data) 16))
	       (statstr (number->string (+ #x10000 stat) 16)))
	  (string-set! datastr 0 #\x)
	  (string-set! statstr 0 #\x)
	  (if (= stat 1)
	      (display datastr)
	      (begin
		(newline)
		(writeln "stat" statstr "data" datastr)))
	  (vme-write-byte (+ rx-base #x30) 0)
	  (glinkfifo)))))




;----------------------------------------------------------------------------------------
;  check INPUT card token memory 
;----------------------------------------------------------------------------------------


(define clear-screen
  (lambda ()
    (display (make-string 2000))
    (set-cursor! 0)))

(define read-tdc
  (lambda ()
    (vme-write-byte (+ (* 32 channel) 9) 0)   ; trigger memory TESTREAD
    (let ((lsb (vme-read-byte (+ (* 32 channel) #x11)))
	  (msn (vme-read-byte (+ (* 32 channel) #x10))))
      (+ lsb (* 256 (band #x0f msn))))))

(define pat-rand #f)  ; #t = fixed pattern   #f = random

(define sdd #x378)  ; parallel port for sender handshake
(define sds (+ 1 sdd))

(define test-all-tokens
  (lambda ()
    (init-rand)
    (set! pat-rand #f)    ; set to random pattern
    (vme-write-word (+ (* channel 32) 6) 0)  ; RX token = 0
    (outp sdd 0)    ; send not ready to sender PC
    (writeln "Sender PC ready?")
    (read-char)
    (rec-all-loop 0 #f)
    (writeln "errors:" (test-all-loop 0 0))
    ))

(define test-all-loop
  (lambda (t e)
    (if (= t 4096)
	e
	(let ((c (check-buf t)))
	  (test-all-loop (add1 t) (if c e (add1 e)))))))

(define rec-all-loop
  (lambda (n s)
    (cond
      ((= n 4096) #t)
      ((and (not s) (not (sender-pc-ready)))
       (writeln "request" n)
       (outp sdd 1)    ; send ready to sender
       (rec-all-loop n #t))
      ((and s (not (sender-pc-ready)))
       (rec-all-loop n #t))
      ((and s (sender-pc-ready))
       (outp sdd 0)    ; send not-ready to sender
       (vme-write-word (+ (* channel 32) 6) (add1 n))  ; RX token = next
       (rec-all-loop (add1 n) #f))
      (else
	(rec-all-loop n #f)))))


(define test-many
  (lambda (c)
    (writeln "INPUT CHANNEL" c)
    (set! channel c)
    (init-rand)
    (set! pat-rand #f)
    (set! err-list ())
    (set-rxt 0)           ; set rx token to 0
    (outp sdd 0)          ; send not ready to sender PC
    (writeln "Sender PC ready?")
    (read-char)
    (writeln "OK")
    (test-many-loop 0 #f)))

(define sender-pc-ready
  (lambda ()
    (zero? (band 8 (inp sds)))))

(define test-many-loop
  (lambda (n s)
    (cond
      ((and (not s) (not (sender-pc-ready)))
;       (display #\.)
;       (writeln "request")
       (outp sdd 1)    ; send ready to sender
       (test-many-loop n #t))
      ((and s (not (sender-pc-ready)))
       (test-many-loop n #t))
      ((and s (sender-pc-ready))
       (check-many (add1 n))
;       (writeln " not request")
       (outp sdd 0)               ; send not ready to sender       
       (test-many-loop (add1 n) #f))
      (else
	(test-many-loop n #f)))))


(define check-many-size 256)
(define err-list ())

(define check-many
  (lambda (n)
    (let ((t (remainder n check-many-size)))
      (if (zero? t)
	  (let ((e (check-block 0 check-many-size ())))
	    (if (null? e)
		#t
		(begin
		  (for-each check-header-print e)
		  (set! err-list (cons e err-list))
		  (if (= (length err-list) 50)
		      (error 'check-many " too many errors ~s" err-list)
		      #t)))
	    (writeln "checked" n " err-list " err-list))
	  #t)
;      (writeln "set tx token" t)
      (set-rxt t))))


(define check-block
  (lambda (t c e)
    (if (= t c)
	e
	(check-block (add1 t) c (if (check-buf t) e (cons t e))))))


(define set-rxt
  (lambda (t)
    (let ((a (+ (* channel 32) 6)))
      (vme-write-word a t)
      (if (= (vme-read-word a) t)
	  #t
	  (writeln "set-rxt  ERROR RX token number not set"))
      )))
    
    

(define check-buf0
  (lambda ()
    (init-rand)
    (check-buf 0)))

(define check-mem
  (lambda (t)
    (vme-write-word (* 32 channel) t)   ; TESTTOKEN = t and TESTADDR = 0
    (check-mem-loop 0)))

(define check-mem-loop
  (lambda (i)
    (if (= i 170) ()
        (begin
          (if (= i 4) (newline) #f)
          (if (= i 164) (newline) #f)
          (display (hex-word (read-tdc)))
          (check-mem-loop (add1 i))))))

(define check-header-print
  (lambda (t)
    (writeln (check-header t))))

(define check-header
  (lambda (t)
    (vme-write-word (* 32 channel) t)   ; TESTTOKEN = t and TESTADDR = 0
    (string-append "TOKEN " 
      (number->string t) 
      " header"
      (hex-word (read-tdc))
      (hex-word (read-tdc))
      (hex-word (read-tdc))
      (hex-word (read-tdc))
      )))
    
(define check-buf
  (lambda (t)
    (check-header t)    
    (let ((errs (check-data-loop 6 0)))
      (if (zero? errs)
	  #t
	  (begin
	    (writeln "data errors" errs)
	    #f)))))


(define init-rand
  (lambda ()
    (load (string-append s88path "bool.so"))))


(define memory-function
  (lambda (n)
    (if pat-rand
	(+ n (* 256 (remainder n 2)))
	(let ((t0 (apply rand8 ()))
	      (t1 (apply rand8 ())))
	  (+ t0 (* 256 (band #x0f t1)))))))

(define check-data-loop
  (lambda (n e)
    (if (= n 166) 
	e
	(let ((token (read-tdc))
	      (expect (memory-function n)))
	  (check-data-loop 
	    (add1 n) 
	    (if (= token expect) 
		e 
		(begin 
		  (writeln  "err addr" n 
		    " memory " (hex-word token)
		    "expect" (hex-word expect))
		  (add1 e))))))))