;;; -*- Mode:LISP; Package:GREY; Base:8; Readtable:t -*-

;; Copyright LISP Machine, Inc. 1984, 1985, 1986
;;    See filename "Copyright.Text" for
;; licensing and release information.

;; This is the assembler and downloader for the color board's microprogram.

;;;;SRAM RELATED FUNCTIONS

;			*****REV4 HARDWARE CHANGE*****
;THESE(I.E. SRAM RELATED)ARE THE ONLY FUNCTIONS WHICH CHANGED DUE TO HARDWARE REVISIONS
;BETWEEN REV'S 3 AND 4.  THE ONLY RELEVANT HARDWARE CHANGE WAS THAT THE "HACKING SRAM" BIT
;MOVED FROM THE 40000 BIT TO THE 100 BIT. THIS RESULTS IN WRITING "500" FOLLOWED BY "100"
;RATHER THAN "40400" FOLLOWED BY "40000", TO STEP THE SRAM ADDRESS

(DEFUN CLR-SRAM-ADR (&AUX NUMBER)
  (WRITE-MODE 100)					;Set HACKING SRAM
  (DO ((N 0 (1+ N)))
      ((BIT-TEST 4 (FUNCALL READ-FUNCTION MODE))
       (SETQ NUMBER (+ N 1)))
    (WRITE-MODE 500)					;Step SRAM ADR till overflow
    (WRITE-MODE 100))
  (WRITE-MODE 500)					;Step once more
  (WRITE-MODE 100)
  NUMBER)

(DEFUN SET-SRAM-ADR (&AUX NUMBER)			;7777 -> SRAMAD
  (WRITE-MODE 100)					;Set HACKING SRAM
  (DO ((N 0 (1+ N)))
      ((BIT-TEST 4 (FUNCALL READ-FUNCTION MODE))
       (SETQ NUMBER (+ N 1)))
    (WRITE-MODE 500)					;Step SRAM ADR till overflow
    (WRITE-MODE 100))
  NUMBER)

(DEFUN WRITE-SRAM-ADR (ADR)
  (CLR-SRAM-ADR)
  (DO ((N 0 (1+ N)))					;INC up to ADR
      ((= N ADR))
    (WRITE-MODE 500)
    (WRITE-MODE 100)))

(DEFCONST LOC-PTR 0)

(DEFUN LOAD-SRAM (&OPTIONAL (OLIST SRAM-OBJECT))
  (WRITE-SRAM-ADR 0)
  (SETQ LOC-PTR 0)
  (FILL-SYNC OLIST))

(DEFUN CHECK-SRAM (&OPTIONAL (OLIST SRAM-OBJECT))
  (WRITE-SRAM-ADR 0)
  (SETQ LOC-PTR 0)
  (CHECK-SYNC OLIST))

(DEFUN FILL-SYNC (L &AUX X)
  (DO ((L L (CDR L)))
      ((NULL L))					;Writes -> SRAM
    (SETQ X (CAR L))
    (COND ((ATOM X)
	   (FUNCALL WRITE-FUNCTION SRAM-DATA X)
	   (WRITE-MODE 500)
	   (WRITE-MODE 100)
	   (SETQ LOC-PTR (1+ LOC-PTR)))
	  ((EQ (CAR X) 'LOC)
;	   (FORMAT T "~%END OF BLOCK: ~O" LOC-PTR)	;Prints out last locs of each block
	   (DO () ((= LOC-PTR (CADR X)))
	     (FUNCALL WRITE-FUNCTION SRAM-DATA 0)
	     (WRITE-MODE 500)
	     (WRITE-MODE 100)
	     (SETQ LOC-PTR (1+ LOC-PTR))))
	  (T (DO N (CAR X) (1- N) (ZEROP N)
		 (FILL-SYNC (CDR X))))))
  LOC-PTR)

(DEFUN CHECK-SYNC (L &AUX X D FLAG)
  (DO ((L L (CDR L)))
      ((NULL L))					;Reads back SRAM and checks against
    (SETQ FLAG NIL)					;SRAM-OBJECT or other array
    (SETQ X (CAR L))
    (COND ((ATOM X)
	   (SETQ D (FUNCALL READ-FUNCTION SRAM-DATA))
	   (WRITE-MODE 500)
	   (WRITE-MODE 100)
	   (COND ((NEQ D X)
		  (FORMAT T "~% LOCATION ~O GOT ~O S/B ~O" LOC-PTR D X)
		  (SETQ FLAG T)))
	   (SETQ LOC-PTR (1+ LOC-PTR)))
	  ((EQ (CAR X) 'LOC)
;	   (FORMAT T "~%END OF BLOCK: ~O" LOC-PTR)	;Prints out last locs of each block
	   (DO () ((= LOC-PTR (CADR X)))
	     (SETQ D (FUNCALL READ-FUNCTION SRAM-DATA))
	     (WRITE-MODE 500)
	     (WRITE-MODE 100)
	     (COND ((NEQ D 0)
		    (FORMAT T "~% LOCATION ~O GOT ~O S/B 0" LOC-PTR D)
		    (SETQ FLAG T)))
	     (SETQ LOC-PTR (1+ LOC-PTR))))
	  (T (DO N (CAR X) (1- N) (ZEROP N)
		 (CHECK-SYNC (CDR X))))))
  FLAG)

(DEFUN SRAM-ADR-TEST (&AUX X)
  (CLR-SRAM-ADR)					;Load address pattern -> SRAM
  (DO ((N 0 (1+ N)))
      ((= N 4096.))
    (FUNCALL WRITE-FUNCTION SRAM-DATA N)
    (WRITE-MODE 500)				;Increment SRAM ADR
    (WRITE-MODE 100))
  (FORMAT T "~%SRAM LOADED")
  (DO ((N 0 (1+ N)))				;SRAM ADR should be back to zero
      ((= N 4096.))
    (SETQ X (FUNCALL READ-FUNCTION SRAM-DATA))
    (IF(NOT (= X N))
       (FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE ~O" N X N))
    (WRITE-MODE 500)
    (WRITE-MODE 100)))

(DEFUN SRAM-DATA-TEST (&AUX X)
  (CLR-SRAM-ADR)
  (DO ((N 0 (1+ N)))
      ((= N 4096.))
    (FUNCALL WRITE-FUNCTION SRAM-DATA 0)
    (SETQ X (FUNCALL READ-FUNCTION SRAM-DATA))
    (IF (NOT (= X 0))
	(FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE 0" N X))
    (FUNCALL WRITE-FUNCTION SRAM-DATA 177777)
    (SETQ X (FUNCALL READ-FUNCTION SRAM-DATA))
    (IF (NOT (= X 177777))
	(FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE 177777" N X))
    (WRITE-MODE 500)
    (WRITE-MODE 100)))

(DEFUN DUMP-SRAM (&OPTIONAL (FIRST-ADR TV-PROG-BASE))
  (CLR-SRAM-ADR)
  (DO ((N 0 (1+ N)))
      ((= N 4096.))
    (IF (>= N FIRST-ADR)
	(FORMAT T "~%LOCATION ~O = ~O" N (FUNCALL READ-FUNCTION SRAM-DATA)))
    (WRITE-MODE 500)
    (WRITE-MODE 100)))
;))

;;;;ASSEMBLER AND UTILITY FUNCTIONS


(DEFVAR *ASSEMBLED-SRAMS* NIL)

(DEFUN GREY-BOARD-VERSION ()
  (IF (AND (BOUNDP 'GREY-PROM-PLIST)
	   GREY-PROM-PLIST)
      (GET GREY-PROM-PLIST :VERSION)))
    
(DEFUN ASSEMBLE-SRAM-SOURCE (&OPTIONAL (SLIST SRAM-SOURCE))
  (LET* ((KEY (LIST SLIST (GREY-BOARD-VERSION)))
	 (CACHE (ASS #'EQUALP KEY *ASSEMBLED-SRAMS*)))
    (WHEN (NULL CACHE)
      (SETQ CACHE (LIST KEY (SUB-ASSEMBLE-SRAM-SOURCE SLIST)))
      (PUSH CACHE *ASSEMBLED-SRAMS*))
    (CADR CACHE)))
		    
(DEFUN SUB-ASSEMBLE-SRAM-SOURCE (SLIST)
  (MAPCAR (FUNCTION ASSEMBLE-INSTRUCTION)
	  (MAPCAN #'MACROEXPAND-INSTRUCTION
		  SLIST)))


(DEFUN MACROEXPAND-INSTRUCTION (INSTRUCTION)
  (IF (ATOM INSTRUCTION)
      (FERROR NIL "BAD SRAM INSTRUCTION SYNTAX: ~S" INSTRUCTION)
    (IF (ATOM (CAR INSTRUCTION))
	(LIST INSTRUCTION)
      (SELECTQ (CAAR INSTRUCTION)
	(IF-VERSION
	 (IF (MEMBER (GREY-BOARD-VERSION) (CDAR INSTRUCTION))
	     (COPYLIST (CDR INSTRUCTION))
	   NIL))
	(OTHERWISE
	 (FERROR NIL "UNKNOWN PSUEDO-OP TYPE IN INSTRUCTION: ~S" INSTRUCTION))))))

(DEFUN ASSEMBLE-INSTRUCTION  (ILIST
			      &AUX COUNT COUNT-MSB
			      (FLD0 '(PRCFG FG0 FG1 FG2 FG3 FG2A FG3A WAIT
				      PRCTV TV0 TV1 TV2 TV3 TV0A PROC REF
				      REFS NOP4 NOP5 NOP6 NOP7 NOP8 NOP8A PROCB
				      REFCB RFSCB PFGCB SPEC4 SPEC5 SPEC6 SPEC7 SPEC8
				      VSYNP VSYNR VSYNS EOL))
			      (FLD1 '(- BLANK))
			      (FLD2 '(- SYNC))
			      (FLD3 '(- FG))
			      (FLD4 '(PROC - REF VIDEO))
			      (FLD5 '(HOLD V+1 V+2 V+STEP LOAD V-1 V-2 V-STEP))
			      (FLD6 '(BRCOND BRZERO - RPCT)))
  
  (COND ((ATOM (CADR ILIST))
	 (COND ((= (LENGTH ILIST) 2)
		(COND ((EQ (CAR ILIST) 'LOC) ILIST)
		      (T (SETQ COUNT (- (CAR ILIST)))		;A RPCT instruction
			 (SETQ COUNT-MSB (LDB 0701 COUNT))
			 (IF (= COUNT-MSB 0)			;If RPCT7 off, use FCN26-NOP8A
			     (DPB COUNT 0310
				  (DPB 3 0002 54000))
			   (DPB COUNT 0310			;If RPCT7 on, use FCN25 -NOP8
				(DPB 3 0002 52000))))))
	       
	       (T
		(DPB (FIND-POS (NTH 0 ILIST) FLD0) 1206
		     (DPB (FIND-POS (NTH 1 ILIST) FLD1) 1101
			  (DPB (FIND-POS (NTH 2 ILIST) FLD2) 1001
			       (DPB (FIND-POS (NTH 3 ILIST) FLD3) 0701
				    (DPB (FIND-POS (NTH 4 ILIST) FLD4) 0502
					 (DPB (FIND-POS (NTH 5 ILIST) FLD5) 0203
					      (DPB (FIND-POS (NTH 6 ILIST) FLD6) 0002 0)
					      )))))))))
	(T
	 (CONS (CAR ILIST) (SUB-ASSEMBLE-SRAM-SOURCE (CDR ILIST)))))) ;Software REPEAT CNT
								  ;[interpreted by
								  ;FILL-SYNC]
(DEFUN FIND-POS (PATTERN PLIST)
  (FIND-POSITION-IN-LIST PATTERN PLIST))

;To use the following function, first do:
;(SETQ SRAM-OBJECT (ASSEMBLE-SRAM-SOURCE SRAM-SOURCE) A NIL)
;Then do: (DRIBBLE-START "<FILENAME>") with MORE PROCESSING disabled.
;         (MAKE-SRAM-OBJECT SRAM-OBJECT).
;         (DRIBBLE-END).
;Next edit the file <FILENAME> to get rid of the cruft at the beginning and end left over
;from DRIBBLE-START and compile the buffer it's in if you want.
;Finally, transfer the edited file to OZ:PS:<NGL>GREY.LISP and delete the old version of
;SRAM-OBJECT.  You now have a list named SRAM-OBJECT which can be used as the
;source code for (LOAD-SRAM <OBJECT-CODE-NAME>) which is also used in INIT.
(DEFUN MAKE-SRAM-OBJECT (LST &AUX (COUNT 0))
  (TERPRI)
  (PRINC "(DEFCONST SRAM-OBJECT")
   (TERPRI)
  (PRINC "   '(")
  (TERPRI)
  (PRINC "         ")
  (DO ((L LST (CDR L)))
      ((NULL L) (PRINC "                    ))") (TERPRI))
    (SETQ COUNT (1+ COUNT))
    (COND ((ATOM (CAR L))
	   (PRINC (CAR L)))
	  ((EQ (CAAR L) 'LOC)
	   (SETQ COUNT 0)
	   (TERPRI)
	   (PRINC "         ")
	   (PRINC (CAR L))
	   (TERPRI)
	   (PRINC "         "))
	  (T (SETQ COUNT 0)
	     (TERPRI)
	     (PRINC " (")
	     (PRINC (CAAR L))
	     (TERPRI)
	     (PRINC "         ")
	     (DO ((M (CDAR L) (CDR M)))
		 ((NULL M)
		  (TAB 8.)
		  (PRINC ")")
		  (TERPRI)
		  (PRINC "        "))
	       (PRINC (CAR M))
	       (COND ((NULL (CDR M))
		      (COND ((BIT-TEST 1 (CAR M)) NIL)
			    (T (TERPRI)
			       (PRINC "         ")))))
	       (COND ((AND (ATOM (CAR M))
			   (BIT-TEST 1 (CAR M)))
		      (TERPRI)
		      (PRINC "         "))
		     (T (PRINC " "))))))
    (COND ((OR (AND (ATOM (CAR L))
		    (BIT-TEST 1 (CAR L)))
	       (LISTP (CADR L))
	       (COND ((>= COUNT 9.)
		      (SETQ COUNT 0)
		      T)))
	   (TERPRI)
	   (PRINC "         "))
	  (T (PRINC " ")))))

(DEFUN TAB (NUM)
  (DOTIMES (I NUM)
    (TYO 211)))

;Figures out how many RAM locations are accessed by the SRAM load using the
;VMA CTL 0-2 controls -- apply to only one half the SRAM load at one time.
;This is useful for debugging SRAM code.
(DEFUN CALC-SYNC (SLST &AUX (SYNCSUM 0) (RC 1))
  (DO ((L (EXPAND-SRAM-OBJECT SLST) (CDR L)))
      ((NULL L) SYNCSUM)
    (COND ((BIT-TEST 1 (CAR L))
	   (SETQ RC (1+ (ABS (LOGXOR 37777777777 (LOGIOR (ASH (CAR L) -4) 37777777400))))))
	  (T (SETQ SYNCSUM (+ SYNCSUM
			      (* RC (CALC-VMA-CTL (CAR L)))))
	     (COND ((BIT-TEST 4 (CAR L))
		    (SETQ RC 1)))))))

(DEFUN CALC-VMA-CTL (NUM)
  (SETQ NUM (ASH (LOGAND 160 NUM) -4))
  (COND ((OR (= NUM 0) (= NUM 4) (= NUM 7)) 0)
	((= NUM 3) 1)
	((= NUM 5) -1)
	((= NUM 6) -2)
	(T NUM)))

(DEFUN EXPAND-SRAM-OBJECT (&OPTIONAL (SRC SRAM-OBJECT))
  (COND ((NULL SRC) NIL)
	(T (APPEND (COND ((ATOM (CAR SRC)) (LIST (CAR SRC)))
			 ((EQ (CAAR SRC) 'LOC) NIL)
			 (T (DO ((N (CAAR SRC) (1- N))
				 (L (CDAR SRC) L)
				 (LST NIL (APPEND LST L)))
				((ZEROP N) LST))))
		   (EXPAND-SRAM-OBJECT (CDR SRC))))))