;;; -*- Mode: LISP; Package: USER -*-

;;; Routines to hack the prom programmer
;;; Type "Select F1 Start" on the "System 19" to put it in remote mode
;;; This program operates at 300 baud at MIT but at 1200 baud at Symbolics.
;;; Other sites should edit in whatever speed they prefer.

;;; Modified 8/8/79 by Moon to use the IOB serial interface
;;; Requires version 9 or later of LMIO;SERIAL.

;;; Useful functions to call are:
;;; PROGRAMMER-RESET - resets everything, reads prom geometry from programmer.
;;;				Call this before trying to do anything else.
;;; PROGRAMMER-UNWEDGE
;;; PROGRAMMER-PROGRAM-PROM - the argument is a prom-name.
;;;   A prom-name is a symbol whose value is an array containing the data.
;;; PROGRAMMER-READ-PROM - argument is a prom-name (there are some optionals too.)
;;;				This reads the prom that is in the programmer into
;;;				an array in the lisp machine.
;;; PROGRAMMER-READ-PROM-FILE - arguments are file name and prom-name.
;;; PROGRAMMER-WRITE-PROM-FILE - arguments are file name and prom-name.
;;; PROGRAMMER-MAKE-BOOTSTRAP - makes a set of Lisp machine bootstrap proms.
;;;				Giving it an argument allows you to do one over.
;;;	The files this runs off of are generated by assembling the prom program
;;;	with the micro-assembler (probably in Maclisp) then loading the file
;;;	AI:MOON;PUNCH into that Lisp and typing (punch)


(DECLARE (SPECIAL PROGRAMMER-STREAM PROGRAMMER-TRACE))
(SETQ PROGRAMMER-TRACE NIL)

(DEFUN GET-PROGRAMMER-CHAR (&OPTIONAL (IMAGE-P NIL))
  (DO ((CHAR))
      (CHAR CHAR)
    (SETQ CHAR (FUNCALL PROGRAMMER-STREAM ':TYI))
    (COND ((NOT IMAGE-P)
	   (SETQ CHAR (LOGAND CHAR 177))
	   (COND ((OR (= CHAR 12) (= CHAR 0))
		  (SETQ CHAR NIL)))))
    (AND CHAR PROGRAMMER-TRACE (TYO CHAR))))

;;; Low level routines to get data to/from the programmer

;;; Send a command to the programmer.  Returns as its first value the response from the
;;; programmer (if one is expected).  Returns as its second value NIL if the command succeded,
;;; UNKNOWN if the command was unknown, and T if the command failed.
;;; RESPONSE-P should be NIL if no response expected but success/failure checked, NONE
;;;  if even success/failure should not be checked, or the length of the expected response
(DEFUN PROGRAMMER-COMMAND (COMMAND &OPTIONAL RESPONSE-P (IMAGE-P NIL) &AUX ACK RESP)
  (PROG ()
    (FUNCALL PROGRAMMER-STREAM ':CLEAR-INPUT)
    (FUNCALL PROGRAMMER-STREAM ':STRING-OUT COMMAND)
    (FUNCALL PROGRAMMER-STREAM ':TYO 15)	;Start the command
    (COND ((NOT RESPONSE-P))
	  ((EQ RESPONSE-P 'NONE)
	   (RETURN NIL NIL))
	  (T (SETQ RESP (MAKE-ARRAY NIL 'ART-STRING RESPONSE-P))
	     (DOTIMES (I RESPONSE-P)
	       (ASET (GET-PROGRAMMER-CHAR IMAGE-P) RESP I))))
    (SETQ ACK (GET-PROGRAMMER-CHAR))
    (OR (= (GET-PROGRAMMER-CHAR) 15)	;Programmer terminates ack with a 15
	(FERROR NIL "Programmer did not send <CR> after ack"))
    (SELECTQ ACK
      (#/> (RETURN RESP NIL))		;Success
      (#/F (RETURN RESP T))		;Failure
      (#/? (RETURN RESP 'UNKNOWN))	;Unknown command
      (OTHERWISE (FERROR NIL "Ack from programmer was ~S, which is Unknown" ACK)))))

;;; Resets the programmer, and reads out various pieces of state information
(DECLARE (SPECIAL PROGRAMMER-DEVICE-WORD-LIMIT PROGRAMMER-BYTE-SIZE
		  PROGRAMMER-VOL-VOH-STATUS))

(DEFUN PROGRAMMER-RESET ()
  (OR (BOUNDP 'PROGRAMMER-STREAM)
      (SETQ PROGRAMMER-STREAM (SI:MAKE-SERIAL-STREAM
				':PARITY NIL
				':NUMBER-OF-DATA-BITS 8
				':BAUD #+MIT 300. #+SYM 1200.)))
  (FUNCALL PROGRAMMER-STREAM ':CLEAR-INPUT)
  (FUNCALL PROGRAMMER-STREAM ':TYO 33)		;This resets the programmer
  (DO ((CHAR (GET-PROGRAMMER-CHAR) (GET-PROGRAMMER-CHAR)))
      ((= CHAR #/>)))
  (DO ((CHAR (GET-PROGRAMMER-CHAR) (GET-PROGRAMMER-CHAR)))
      ((= CHAR 15)))				;Wait for programmer to ack
  (LET ((RESP (PROGRAMMER-COMMAND "R" 7)))
    (SETQ PROGRAMMER-DEVICE-WORD-LIMIT (HEX-STRING-TO-FIXNUM (NSUBSTRING RESP 0 3))
	  PROGRAMMER-BYTE-SIZE (HEX-STRING-TO-FIXNUM (NSUBSTRING RESP 4 5))
	  PROGRAMMER-VOL-VOH-STATUS (HEX-STRING-TO-FIXNUM (NSUBSTRING RESP 6 7))))
  T)

(DEFUN HEX-STRING-TO-FIXNUM (STRING &AUX (NUM 0) CHAR)
  (DOTIMES (I (STRING-LENGTH STRING))
    (SETQ CHAR (AREF STRING I))
    (SETQ NUM (+ (* NUM 20)
		 (COND ((AND ( CHAR #/0) ( CHAR #/9))
			(- CHAR #/0))
		       ((AND ( CHAR #/A) ( CHAR #/F))
			(- CHAR (- #/A 10.)))
		       (T (RETURN NIL))))))
  NUM)

;;; Reads the contents of the ram using Intel Intellec 8/MDS format, code 83
(DECLARE (SPECIAL PROGRAMMER-CHECKSUM))

(DEFUN PROGRAMMER-READ-RAM (&OPTIONAL (ARRAY (MAKE-ARRAY NIL 'ART-8B
							 (1+ PROGRAMMER-DEVICE-WORD-LIMIT))))
  (PROGRAMMER-RESET)
  (MULTIPLE-VALUE-BIND (IGNORE FAILURE)
      (PROGRAMMER-COMMAND "83A" NIL)
    (AND FAILURE
	 (FERROR NIL "Cannot set transfer format"))
    (PROGRAMMER-COMMAND "O" 'NONE)
    (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE)
	 (ARRAY-LEN (ARRAY-LENGTH ARRAY)))
	(())
      ;Start character is a colon
      (DO CHAR (GET-PROGRAMMER-CHAR) (GET-PROGRAMMER-CHAR) (= CHAR #/:))
      (SETQ BYTE-COUNT (HEX-READ-BYTE))
      (SETQ ADR (+ (LSH (HEX-READ-BYTE) 8.) (HEX-READ-BYTE)))
      (SETQ RECORD-TYPE (HEX-READ-BYTE))
      (SELECTQ RECORD-TYPE
	(00					;Data record
	 (COND (( ADR ARRAY-LEN)
		;; With the new software, it seems that the programmer can overrun the array
		(FORMAT T "~&Programmer sending too much data, resetting.")
		(PROGRAMMER-RESET)
		(RETURN NIL)))
	 (DOTIMES (I BYTE-COUNT)
	   (LET ((BYTE (HEX-READ-BYTE)))
	     (AND  (< (+ ADR I) ARRAY-LEN)
		   (ASET BYTE ARRAY (+ ADR I)))))
	 (SETQ CS (LOGAND (- PROGRAMMER-CHECKSUM) 377))
	 (COND (( (SETQ RECORD-TYPE (HEX-READ-BYTE)) CS)
		(FORMAT T "Checksum error, trying again~%")
		(PROGRAMMER-RESET)
		(RETURN (PROGRAMMER-READ-RAM ARRAY)))))
	(01					;EOF record
	 (DO CHAR (GET-PROGRAMMER-CHAR) (GET-PROGRAMMER-CHAR) (= CHAR #/>))
	 (GET-PROGRAMMER-CHAR)
	 (RETURN NIL)))))			;Read trailing <CR>
  ARRAY)


;;; Sets the contents of the ram using Intel Intellec 8/MDS format, code 83
(DEFUN PROGRAMMER-WRITE-RAM (ARRAY &OPTIONAL (RECORD-MAX-LENGTH 20))
  (PROGRAMMER-RESET)				;Reset programmer, read word limit info
  (PROGRAMMER-READ-ERROR-STATUS)		;Reset the error code to zero
  (MULTIPLE-VALUE-BIND (IGNORE FAILURE)
      (PROGRAMMER-COMMAND "83A" NIL)
    (AND FAILURE
	 (FERROR NIL "Cannot set transfer format"))
    (PROGRAMMER-COMMAND "I" 'NONE)
    (FUNCALL PROGRAMMER-STREAM ':TYO 15) (FUNCALL PROGRAMMER-STREAM ':TYO 12)
    (DOTIMES (I 20.)				;Seems to need some pad characters
      (FUNCALL PROGRAMMER-STREAM ':TYO 0))
    (DO ((LEFT (1+ PROGRAMMER-DEVICE-WORD-LIMIT) (- LEFT RECORD-LEN))
	 (ARRAY-LENGTH (ARRAY-LENGTH ARRAY))
	 (IDX 0 (+ IDX RECORD-LEN))
	 (CHECKSUM)
	 (RECORD-LEN))
	(( LEFT 0))
      (SETQ RECORD-LEN (MIN LEFT RECORD-MAX-LENGTH))
      (FUNCALL PROGRAMMER-STREAM ':TYO #/:)
      (NUMBER-PRINT RECORD-LEN 8. 16. PROGRAMMER-STREAM)	;Byte count
      (NUMBER-PRINT IDX 16. 16. PROGRAMMER-STREAM)	;Address
      (SETQ CHECKSUM (+ RECORD-LEN (LOGAND IDX 377) (LDB 1010 IDX)))
      (FUNCALL PROGRAMMER-STREAM ':STRING-OUT "00")	;Record type 0: data
      (DOTIMES (I RECORD-LEN)
	(NUMBER-PRINT (COND ((< (+ IDX I) ARRAY-LENGTH)
			     (SETQ CHECKSUM (+ CHECKSUM (AREF ARRAY (+ IDX I))))
			     (AREF ARRAY (+ IDX I)))
			    (T 0))
		      8. 16. PROGRAMMER-STREAM))
      (NUMBER-PRINT (LOGAND (- CHECKSUM) 377) 8. 16. PROGRAMMER-STREAM)
      (FUNCALL PROGRAMMER-STREAM ':TYO 15) (FUNCALL PROGRAMMER-STREAM ':TYO 12))
    (FUNCALL PROGRAMMER-STREAM ':STRING-OUT ":00000001")	;EOF record
    (FUNCALL PROGRAMMER-STREAM ':TYO 15) (FUNCALL PROGRAMMER-STREAM ':TYO 12)
    (PROGRAMMER-RESET)
    (PROGRAMMER-READ-ERROR-STATUS)))

(DEFUN HEX-READ-BYTE (&AUX BYTE (STRING (MAKE-ARRAY NIL 'ART-STRING 2)))
  (ASET (GET-PROGRAMMER-CHAR) STRING 0)
  (ASET (GET-PROGRAMMER-CHAR) STRING 1)
  (SETQ PROGRAMMER-CHECKSUM
	(+ PROGRAMMER-CHECKSUM (SETQ BYTE (HEX-STRING-TO-FIXNUM STRING))))
  (RETURN-ARRAY STRING)
  BYTE)

(DEFUN NUMBER-PRINT (NUMBER SIG-BITS BASE &OPTIONAL (STREAM STANDARD-OUTPUT))
  (LET ((DIG)
	(DIGITS)
	(BITS (1- (HAULONG BASE))))
    (SETQ DIGITS (// (+ SIG-BITS BITS -1) BITS))
    (DOTIMES (I DIGITS)
      (SETQ DIG (LDB (+ BITS (LSH (* BITS (- DIGITS I 1)) 6.)) NUMBER))
      (COND ((< DIG 10.) (TYO (+ DIG #/0) STREAM))
	    (T (TYO (+ DIG #/A -10.) STREAM))))))

(DEFUN NUMBER-LENGTH (NUMBER BASE)
  (// (+ (HAULONG NUMBER) (1- (HAULONG BASE)) -1)
      (1- (HAULONG BASE))))

(DEFUN PROGRAMMER-READ-ERROR-STATUS ()
  (PROGRAMMER-COMMAND "F" 8.))

(DEFUN PROGRAMMER-UNWEDGE ()
  (PROGRAMMER-RESET)
  (PROGRAMMER-COMMAND "I" 'NONE)
  (PROGRAMMER-RESET)
  (PROGRAMMER-READ-ERROR-STATUS))

(DEFUN PROGRAMMER-PROGRAM-PROM (PROM-PROGRAM &AUX (PROM-ARRAY (SYMEVAL PROM-PROGRAM)))
  (FORMAT T "~&Writing ~A into programmer~%" PROM-PROGRAM)
  (DO ((ERROR-CODE (PROGRAMMER-WRITE-RAM PROM-ARRAY)
		   (PROGRAMMER-WRITE-RAM PROM-ARRAY)))
      ((STRING-EQUAL ERROR-CODE "00000000"))
    (FORMAT T "Error writing PROM, error code ~a. Retrying.~%" ERROR-CODE))
  (FORMAT T "Verifying ram~%")
  (LET ((ARRAY (PROGRAMMER-READ-RAM))
	(PROM-LENGTH (ARRAY-LENGTH PROM-ARRAY)))
    (COND ((DOTIMES (I (ARRAY-LENGTH ARRAY))
	     (COND ((< I PROM-LENGTH)
		    (COND (( (AREF ARRAY I) (AREF PROM-ARRAY I))
			   (FORMAT T "Data compare error, ")
			   (RETURN T))))
		   (( (AREF ARRAY I) 0)
		    (FORMAT T "Unwritten data not zero, ")
		    (RETURN T))))
	   (FORMAT T "Ram readback failed, try again?~%")
	   NIL)
	  (T (PROGRAMMER-WRITE-PROM)
	     T))))

(DEFUN PROGRAMMER-WRITE-PROM ()
  (PROG (VAL FAIL)
   (FORMAT T "~&Insert fresh PROM, type Y when ready: ")
   (OR (Y-OR-N-P) (RETURN NIL))
   (MULTIPLE-VALUE (VAL FAIL)
     (PROGRAMMER-COMMAND "B"))
   (COND (FAIL
	  (FORMAT T "~&PROM is not blank, proceed anyway? ")
	  (OR (Y-OR-N-P) (RETURN NIL))))
   (MULTIPLE-VALUE (VAL FAIL)
     (PROGRAMMER-COMMAND "T"))
   (COND (FAIL
	  (FORMAT T "~&PROM has bad bit, proceed anyway? ")
	  (OR (Y-OR-N-P) (RETURN NIL))))
   (FORMAT T "~&Programming PROM")
   (MULTIPLE-VALUE (VAL FAIL)
     (PROGRAMMER-COMMAND "P"))
   (COND (FAIL
	  (FORMAT T "~&Programming failed.")
	  (RETURN NIL)))
   (FORMAT T "~&Verifying device.")
   (MULTIPLE-VALUE (VAL FAIL)
     (PROGRAMMER-COMMAND "V"))
   (AND FAIL (FORMAT T "~&PROM fails to verify."))))

;;; Routines to read and write "Standard" format proms
(DEFUN PROGRAMMER-READ-PROM-FILE (FILENAME PROM-NAME)
  (LET ((FILE (OPEN FILENAME '(IN)))
	(PACKAGE (PKG-FIND-PACKAGE "USER"))
	(IBASE 8.)
	(TOKEN))
    (SETQ TOKEN (READ FILE))
    (OR (EQ TOKEN 'USER:PROM)
	(FERROR NIL "Starting token is, ~S, not ~S" TOKEN 'USER:PROM))
    (DO () (())
      (SETQ TOKEN (READ FILE))
      (AND (NUMBERP TOKEN) (RETURN NIL))
      (PUTPROP PROM-NAME (READ FILE) TOKEN))
    (DO ((TOKEN TOKEN (READ FILE))
	 (ARRAY (MAKE-ARRAY NIL 'ART-Q 1000))
	 (LEN 1000)
	 (MAX -1))
	((EQ TOKEN 'USER:END)
	 (SET PROM-NAME (ADJUST-ARRAY-SIZE ARRAY (1+ MAX))))
      (AND (> TOKEN MAX) (SETQ MAX TOKEN))
      (COND (( TOKEN LEN)
	     (SETQ LEN (+ LEN 1000))
	     (ADJUST-ARRAY-SIZE ARRAY LEN)))
      (ASET (READ FILE) ARRAY TOKEN))
    (CLOSE FILE)))

(DEFUN PROGRAMMER-WRITE-PROM-FILE (PROM-NAME FILENAME)
  (LET ((FILE (OPEN FILENAME '(OUT)))
	(BASE 8.)
	(ARRAY (SYMEVAL PROM-NAME)))
    (PRINC "PROM " FILE)
    (DOLIST (PROP 'USER:(LOCATION SUM-CHECK))
      (FORMAT FILE "~A ~A " PROP (GET PROM-NAME PROP)))
    (TERPRI FILE) (TERPRI FILE)
    (DOTIMES (I (ARRAY-LENGTH ARRAY))
      (FORMAT FILE "~O ~O ~%" I (AREF ARRAY I)))
    (FORMAT FILE "~%END ~%")
    (CLOSE FILE)))

(DEFUN PROGRAMMER-READ-PROM (PROM-NAME &OPTIONAL (LOCATION 'UNKNOWN) (RAM-P NIL))
  (OR RAM-P (PROGRAMMER-COMMAND "L"))
  (SET PROM-NAME (PROGRAMMER-READ-RAM))
  (PUTPROP PROM-NAME LOCATION 'USER:LOCATION)
  (PUTPROP PROM-NAME (PROGRAMMER-COMMAND "S" 4) 'USER:SUM-CHECK)
  PROM-NAME)

;;; LISP MACHINE Specific stuff

;;; Routine to load and programm the bootstrap Prom set
(DEFUN PROGRAMMER-MAKE-BOOTSTRAP (&OPTIONAL (FROM NIL)
					    (DIR "LISPM1;")
					    &AUX PROM-FILE-LIST)
  (SETQ PROM-FILE-LIST `((CADR-1B19 . ,(STRING-APPEND "AI:" DIR "PROM 1B19"))
			 (CADR-1B17 . ,(STRING-APPEND "AI:" DIR "PROM 1B17"))
			 (CADR-1C20 . ,(STRING-APPEND "AI:" DIR "PROM 1C20"))
			 (CADR-1D16 . ,(STRING-APPEND "AI:" DIR "PROM 1D16"))
			 (CADR-1E19 . ,(STRING-APPEND "AI:" DIR "PROM 1E19"))
			 (CADR-1E17 . ,(STRING-APPEND "AI:" DIR "PROM 1E17"))))
  (OR FROM
      (DOLIST (PROM PROM-FILE-LIST)
	(PROGRAMMER-READ-PROM-FILE (CDR PROM) (CAR PROM))))
  (DOLIST (PROM PROM-FILE-LIST)
    (AND FROM
	 (EQ (CAR PROM) FROM)
	 (SETQ FROM NIL))
    (OR FROM (DO () ((PROGRAMMER-PROGRAM-PROM (CAR PROM))))))
  'DONE)