;;; -*- Mode:LISP; Package:LAMBDA; Lowercase:T; BASE:8; readtable: ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;


; 6/10/83 Pace
; 1/04/84 RDM "Modification to create symbol lambda-major-version-number, so that
;	      the software can treat version 3's different from version 2's ..."

(defconst lambda-config-prom-base-address 17777000)
(defconst old-lambda-part-number-begin 17777000)
(defconst lambda-string "LMI LAMBDA")
(defvar lambda-minor-version-number nil)
(defvar lambda-major-version-number nil)
(defconst medium-color-string "LMI MEDIUM COLOR")
;(defvar medium-color-slot nil)

(defconst old-memory-part-number-begin (- 17777777 43))
(defconst old-memory-string "GARY'S RAM")

(defconst general-part-number-begin 17777731)
(defconst general-part-number-length 28.)

(defconst *look-across-bus-couplers* t)

(defstruct (config-prom (:type :list))
  cp-string-to-match
  cp-board-type
  cp-offset)


(DEFVAR interesting-boards NIL "ALIST OF BOARD PROM STRINGS")

(DEFMACRO DEFINE-BOARD-TYPE (NAME PROM-STRINGS)
  `(*DEFINE-BOARD-TYPE ',NAME ',PROM-STRINGS))

(DEFUN *DEFINE-BOARD-TYPE (NAME PROM-STRINGS)
  (WHEN (SI:RECORD-SOURCE-FILE-NAME NAME 'DEFINE-BOARD-TYPE)
    (DOLIST (ST PROM-STRINGS)
      (LET ((STRING (IF (ATOM ST) ST (CAR ST)))
	    (OFFSET (IF (ATOM ST) 0 (CADR ST))))
      (SETQ INTERESTING-BOARDS (DELQ (ASS #'STRING-EQUAL STRING INTERESTING-BOARDS) INTERESTING-BOARDS))
      (SETQ INTERESTING-BOARDS (APPEND INTERESTING-BOARDS
				       (LIST (MAKE-CONFIG-PROM CP-STRING-TO-MATCH STRING
							       CP-BOARD-TYPE NAME
							       CP-OFFSET OFFSET))))))
    NAME))


(DEFINE-BOARD-TYPE SDU (("SDU" 8)))

(DEFINE-BOARD-TYPE VCMEM ("PROTOTYPE VCMEM" ("VCM" 8)))

(DEFINE-BOARD-TYPE RAM-128K ("PROTOTYPE RAM" ("MEM" 8) ("MEM" 9)))

(DEFINE-BOARD-TYPE RAM-512K ("415-0001MEM"	; mwt 6/19/84
			     ("1MEM" 7)		;pace 1/28/85
			     ))

(DEFINE-BOARD-TYPE RAM-1024K ("LMI 4-MEGABYTE"))
(DEFINE-BOARD-TYPE RAM-2048K ("LMI 8-MEGABYTE"))
(DEFINE-BOARD-TYPE RAM-3072K ("LMI 12-MEGABYTE"))
(DEFINE-BOARD-TYPE RAM-4096K ("LMI 16-MEGABYTE"))


(DEFINE-BOARD-TYPE LAMBDA ("LMI LAMBDA" "LMI AVP"))



(DEFINE-BOARD-TYPE LMI-MEDIUM-COLOR ("LMI MEDIUM COLOR"))

(DEFINE-BOARD-TYPE bus-coupler ("LMI BUS COUPLER"))

(DEFINE-BOARD-TYPE QUAD ("LMI QUAD VIDEO"))

(DEFINE-BOARD-TYPE MC68000 (("PROTOTYPE CPU" 0)
			    ("CPU" 8)))


(defvar *special-setup-slots* nil "This is a global variable used as a return value during the setup processes")


(defun setup-nubus-configuration (&optional (print-flag nil))
  (cond ((typep *proc* 'lambda-via-local-access)
	 (format t "~&;Nubus setup call redundant, using *PROC* and *ALL-PROCS* info~%"))
	('else
	 (make-nubus-configuration-array print-flag)
	 (initialize-rg-slot)
;  (initialize-mem-slot)
	 (initialize-tv-slot)
;  (initialize-medium-color-slot)
	 (find-and-initialize-memories)
	 (print-nubus-configuration)
	 t)))

(defun make-nubus-configuration-array-serial ()
  (aset '(lambda "LMI LAMBDA V2.1") nubus-configuration-array 0)
  (aset '(vcmem "VCMEM ???") nubus-configuration-array 10)
  (aset '(ram-128k "RAM ???") nubus-configuration-array 11)
  (aset '(ram-128k "RAM ???") nubus-configuration-array 12)
  (aset '(m68000 "CPU ???") nubus-configuration-array 13)
  (aset '(ram-128k "RAM ???") nubus-configuration-array 14)
  (aset '(sdu "SDU ???") nubus-configuration-array 17)
  nubus-configuration-array)

;first 20 are slots in prime NUBUS.  next 20 are slots across lowest numbered bus coupler,
; etc.  We randomly provide for two couplers for now.
(defconst nubus-configuration-array (make-array 60))

(defun make-nubus-configuration-array (&optional print-flag)
  (fillarray nubus-configuration-array nil)
  (cond ((null (access-path-lmi-serial-protocol *proc*))
	 (make-nubus-configuration-array-real print-flag))
	(t
	 (make-nubus-configuration-array-serial))))


(defun make-nubus-configuration-array-real (print-flag)
  (make-nubus-configuration-array-one-bus ':config-offset 0 ':print-flag print-flag)
  (dotimes (i 20)
    (cond ((eq (car (aref nubus-configuration-array i)) 'bus-coupler)
	   (make-nubus-configuration-array-one-bus
	     ':print-flag print-flag
	     ':config-offset 20
	     ':find-remote-coupler t)
	   (make-nubus-configuration-array-one-bus
	     ':print-flag print-flag
	     ':config-offset 20
	     ':find-remote-coupler nil)))))

(defun make-nubus-configuration-array-one-bus (&key config-offset
					       &optional
					       find-remote-coupler
					       print-flag
					       &aux
					       seen-a-coupler)
  (do ((slot (+ config-offset 17) (1- slot))
       configuration-string
       base-string)
      ((< slot config-offset))
    (condition-case (condition)
	(progn
	 (setq configuration-string
	       ;;most boards get their string from here
	       (get-string-from-nubus slot
				      general-part-number-begin
				      general-part-number-length))
	 (setq base-string
	       ;;some boards start from the base of the prom
	       (get-string-from-nubus slot lambda-config-prom-base-address 15.)))
      (:no-error
       (find-board-type-of-string slot print-flag configuration-string base-string)
       (cond ((eq (car (aref nubus-configuration-array slot)) 'bus-coupler)
	      (cond ((not (null seen-a-coupler))
		     (ferror nil "there seem to be two couplers on this bus"))
		    ((< slot 20)
		     (initialize-local-coupler-if-necessary slot)
		     (setq seen-a-coupler t)
		     )
		    ((not (null find-remote-coupler))
		     (initialize-far-coupler-if-necessary slot)
		     (return))
		    (t
		     (setq seen-a-coupler t)))))
       )
      (nubus-timeout
       (if print-flag
	   (format t "~&Bus error on slot ~o: ~a" slot (send condition ':report nil)))
       (aset '(empty) nubus-configuration-array slot))))
    
  (cond ((eq (car (aref nubus-configuration-array 17)) 'unknown)
	 (aset '(sdu "FAKE SDU STRING") nubus-configuration-array 17)))
    
  (find-old-memories config-offset)
  
  (look-for-2mb-memories config-offset)
  )

(defun find-board-type-of-string (slot print-flag &rest strings)
  (prog done ()
   (dolist (str strings)
     (if print-flag
	 (format t "~%trying to figure out ~s" str))
     (dolist (board interesting-boards
		    ;;whatever this board is, it's not in the interesting-boards list
		    (aset (list 'unknown (copy-list strings))
			  nubus-configuration-array slot))
       (let ((chars-to-match (string-length (cp-string-to-match board))))
	 (if print-flag
	     (format t "~%Comparing ~s+~o and ~s."
		     str (cp-offset board) (cp-string-to-match board)))
	 (cond ((string-equal str
			      (cp-string-to-match board)
			      :start1
			      (cp-offset board)	;idx1
			      :start2
			      0			;idx2
			      :end1
			      (+ chars-to-match (cp-offset board))	;lim1
			      :end2
			      chars-to-match)	;lim2
		(if print-flag (format t "~%Compared!!"))
		(aset (list (cp-board-type board) str) nubus-configuration-array slot)
		(return-from done nil))))))))


(defun print-nubus-configuration ()
  (format t "~&Octal Dec Hex~15tDescription")
  (dotimes (i (array-length nubus-configuration-array))
    (let ((board (car (aref nubus-configuration-array i))))
      (cond ((and (not (null board)) (not (eq board 'empty)))
	     (format t "~&~4o~:*   ~2d~:*  ~16,2r~15t~s ~{~S~^ ~}"
		     i (car (aref nubus-configuration-array i))
		     (if (atom (cadr (aref nubus-configuration-array i)))
			 (list (cadr (aref nubus-configuration-array i)))
			 (cadr (aref nubus-configuration-array i)))
		     
		     ))))))

(defconst coupler-mode-reg-addr 17776777)

(defun lam-read-coupler-mode-reg (slot)
  (send *proc* :bus-slot-read slot coupler-mode-reg-addr))

(defun lam-write-coupler-mode-reg (slot data)
  (send *proc* :bus-slot-write slot coupler-mode-reg-addr data))

(defvar *reinitialize-bus-couplers* nil)

(defun initialize-local-coupler-if-necessary (slot)
  (let ((adr (dpb slot (byte 4 24.) #xf0fff7fc)))
    (cond ((not (= (ldb 0404 (bus-read adr)) #xe))
	   (format t "~&Initializing coupler in slot ~o" slot)
	   (bus-write adr 1)))
    (bus-write adr (dpb #xe 0404 (if (= si:processor-type-code si:cadr-type-code)
				     16	; enable timeouts
				   10016)))))

(defun initialize-far-coupler-if-necessary (slot)
  (bus-write (dpb slot (byte 4 24.) #xe0fff7fc)
	     (dpb #xe 0404 (if (= si:processor-type-code si:cadr-type-code)
			       16		; enable timeouts
			     10016))))

(defun reinitialize-couplers ()
  (dotimes (i 20)
    (cond ((eq (car (aref nubus-configuration-array i)) 'bus-coupler)
	   (format t "~&Local coupler in slot ~o ... " i)
	   (initialize-local-coupler-if-necessary i)
	   (return))))
  (dotimes (i 20)
    (cond ((eq (car (aref nubus-configuration-array (+ i 20))) 'bus-coupler)
	   (format t "Far coupler in slot ~o" (+ 20 i))
	   (initialize-far-coupler-if-necessary (+ i 20))
	   (return))))
  t)

(defun initialize-local-coupler (slot local-quad)
  (lam-write-coupler-mode-reg slot 1)
  (lam-write-coupler-mode-reg slot
			      (dpb local-quad 404
				   (if (= si:processor-type-code si:cadr-type-code)
				       10016 ; enable timeouts
				     16))))

(defun initialize-far-coupler (reverse-quad-slot)
  (let ((far-coupler (dotimes (i 16.)
		       (if (eq (car (aref nubus-configuration-array (+ i 16.))) 'bus-coupler)
			   (return (dpb #xe 0404 i))))))
    (cond ((null far-coupler)
	   (ferror nil "couldn't find far coupler")))
    (bus-write (dpb far-coupler (byte 8 24.) #xfff7fc)
	       (dpb reverse-quad-slot
		    0404
		    (if (= si:processor-type-code si:cadr-type-code)
			10016
		      16)))))

;search one NUBUS for 2mb memories.
;this is for the prototype - we only have one of these, and have to send it back someday
(defun look-for-2mb-memories (&optional (config-array-offset 0))
  (dotimes (slot 17)
    (condition-case ()
	(cond ((and
		 (string-equal (get-string-from-nubus
				 (+ slot config-array-offset) 17777000 5) "")
		 (not (string-equal (get-string-from-nubus (+ slot config-array-offset)
							   17777005 3) ""))
		 (string-equal (get-string-from-nubus
				 (+ slot config-array-offset) 17777010 5) ""))
	       (aset (list 'ram-512k "2 mb ram board") nubus-configuration-array
		     (+ slot config-array-offset))
	       (format t "~&Found a 2 mb memory in slot ~o" (+ slot config-array-offset))))
      (nubus-timeout nil))))

;search one NUBUS for old memories
(defun find-old-memories (&optional (config-array-offset 0))
  (dotimes (slot 17)
    (condition-case ()
	(cond ((= (logand 177 (bus-read (+ #xf0000000
					   (ash (+ config-array-offset slot) 24.)
					   (* 4 old-memory-part-number-begin))))
		  (aref old-memory-string 0))
	       (let ((memory (get-string-from-nubus
			       (+ config-array-offset slot)
			       old-memory-part-number-begin
			       10.)))
		 (aset (list 'ram-128k memory) nubus-configuration-array
		       (+ config-array-offset slot)))))
      (nubus-timeout nil))))
  
(defun get-configuration-string-from-nubus (slot)
 "This works for most boards"
; but not "base string" ones.  See make-nubus-configuration-array-one-bus.
  (get-string-from-nubus slot
			 general-part-number-begin
			 general-part-number-length))

(defun get-string-from-nubus (slot address length)
  (let ((string (make-array length ':type 'art-string)))
    (dotimes (i length)
      (aset (logand 177 (bus-read (+ #xf0000000
				     (ash slot 24.)
				     (* 4 (+ address i)))))
	    string
	    i))
    string))

(defun print-conf-array ()
  (dotimes (i (array-length nubus-configuration-array))
    (format t "~&Slot ~O: ~S" i (aref nubus-configuration-array i))))


;** see following function **
(defun initialize-rg-slot (&optional (find-it t))
  (cond (find-it
	 (dotimes (slot (array-length nubus-configuration-array)
			(ferror nil "Can't find an RG board"))
	   (cond ((eq 'lambda (car (aref nubus-configuration-array slot)))
		  (setf (getf *special-setup-slots* :RG-SLOT) slot)
		  (return))))))
  (let ((rg-string (cadr (aref nubus-configuration-array (getf *special-setup-slots* :rg-slot)))))
    (if find-it
	(format t "~&Using ~S with RG board in slot ~O" rg-string (getf *special-setup-slots* :rg-slot)))
   ;only version 4 really wins now.
    (let ((version-start (string-search " V" rg-string)))
      (cond ((null version-start)
	     (ferror nil "No V for version in ~s" rg-string)))
      (incf version-start 2)
      (let ((version-end (string-search-char #/. rg-string)))
	(setq lambda-major-version-number
	      (parse-number rg-string version-start version-end 10.))
	(if (not (numberp lambda-major-version-number))
	    (ferror nil "couldn't get major version number for lambda from ~s" rg-string))
	(setq lambda-minor-version-number nil)
	(cond ((numberp version-end)
	       (setq lambda-minor-version-number
		     (parse-number rg-string (1+ version-end) nil 10.))
	       (if (not (numberp lambda-minor-version-number))
		   (ferror nil "couldn't get minor version number for lambda from ~s ~s"
			   rg-string
			   (substring rg-string (1+ version-end))
			   ))))))))

(defun get-lambda-versions-from-config-string (prom-string)
   ;only version 4 really wins now.
    (let ((version-start (string-search " V" prom-string))
	  major-version minor-version)
      (cond ((null version-start)
	     (ferror nil "No V for version in ~s" prom-string)))
      (incf version-start 2)
      (let ((version-end (string-search-char #/. prom-string)))
	(setq major-version
	      (parse-number prom-string version-start version-end 10.))
	(if (not (numberp major-version))
	    (ferror nil "couldn't get major version number for lambda from ~s" prom-string))
	(setq minor-version nil)
	(cond ((numberp version-end)
	       (setq minor-version
		     (parse-number prom-string (1+ version-end) nil 10.))
	       (if (not (numberp minor-version))
		   (ferror nil "couldn't get minor version number for lambda from ~s ~s"
			   prom-string
			   (substring prom-string (1+ version-end))
			   )))))
      (list major-version minor-version)))

(defun initialize-tv-slot ()
  (dotimes (slot (array-length nubus-configuration-array)
		 (format t "~&No VCMEM board selected.~&"))
    (cond ((eq 'VCMEM (car (aref nubus-configuration-array slot)))
	   (setf (getf *special-setup-slots* :TV-SLOT) slot)
	   (format t "~%Using VCMEM in slot ~s" slot)
	   (return t)))))

(defun initialize-medium-color-slot ()
  (setf (getf *special-setup-slots* :MEDIUM-COLOR-SLOT) nil)	 ;PUT THIS BACK WHEN BOARD IS HANDLING BUS CYCLES
  (dotimes (slot (array-length nubus-configuration-array)
		 (format t "~&No medium color board selected.~&"))
    (cond ((eq 'lmi-medium-color (car (aref nubus-configuration-array slot)))
	   (SETF (getf *special-setup-slots* :MEDIUM-COLOR-SLOT) slot)
	   (format t "~&Using LMI-MEDIUM-COLOR in slot ~s" slot)
	   (return t)))))

;;; not needed anymore. subsumed by MEMORY-CONFIGURATION instance variable in *PROC*
;(defun initialize-mem-slot (&aux (perfered-memory-board-list '(14 4)))
;  (setq mem-slot nil)
;  (let ((mem-info))
;    (dolist (slot perfered-memory-board-list)
;      (cond ((string-equal "RAM" (string (car (aref nubus-configuration-array slot))) 0 0 3 3)
;	     (setq mem-slot slot)
;	     (setq mem-info (aref nubus-configuration-array slot))
;	     (return t))))
;    (cond ((null mem-info)
;	   (dotimes (slot (array-length nubus-configuration-array))
;	     (cond ((string-equal "RAM" (string (car (aref nubus-configuration-array slot)))
;				  0 0 3 3)
;		    (setq mem-slot slot)
;		    (setq mem-info (aref nubus-configuration-array slot))
;		    (return t))))))
;    (cond ((null mem-info)
;	   (format t "~&No memory board selected.~&"))
;	  (t
;	   (format t "~&Using memory board ~S in slot ~O" (cadr mem-info) mem-slot)))))

(defun get-list-of-memory-slots ()
  (loop for i = 0 then (1+ i) until (= i (array-length nubus-configuration-array))
	when (string-equal "RAM" (string (car (aref nubus-configuration-array i)))
			   :start1 0 :start2 0 :end1 3 :end2 3)
	collect i))

(defun print-memory-slots ()
  (dolist (board (get-list-of-memory-slots))
    (format t "~&Slot ~O: ~S" board (cadr (aref nubus-configuration-array board)))))

;(defconst *use-configuration-structure* nil)
(defconst *configuration-pointer* nil)
;(defconst *proc-configuration-pointer* nil)

(defun find-and-initialize-memories ()
  (let ((memory-boards (get-list-of-memory-slots)))
    (dolist (slot memory-boards)
      (if (eq (car (aref nubus-configuration-array slot)) 'ram-128k)
	  (memory-init slot)))
    memory-boards))

(DEFUN PRINT-CONFIG-PROM (slot &optional (start 0))
  (let ((bottom (ash 17777000 2)))
	 ; get a timeout now, if it is going to happen
    (send *proc* :bus-slot-read slot (+ bottom (* start 4)))
    (DO ((C (* start 4) (1+ c)))
	((>= c 512.))
      (if (zerop (logand c 77))
	  (format t "~&~4O ~7O: " c (+ bottom (* 4 c))))
      (FUNCALL standard-output ':TYO
	       (LOGAND 177 (send *proc* :bus-slot-read slot (+ bottom (* 4 C))))))))

(defun print-all-config-proms ()
  (dotimes (i 16.)
    (format t "~&Index ~O: " i)
    (condition-case ()
	(print-config-prom i)
      (nubus-timeout (format t "empty")))))

(defconst config-prom (make-array 512.))

; The roms start with all zeros, so the config-prom array is first filled with zeros.
; Then, the data is entered from a string.  The machine reads the inverse of the
; data written into the prom, so the data is inverted as it moves from the string to
; the prom array.


(defun make-lambda-config-prom (&optional (string "LMI LAMBDA V3.0"))
  "Fill the array CONFIG-PROM with the given string in preparation for programming
a 74S472 prom for the lambda.  The string should start with all of the letters of
the variable LAMBDA-STRING, and may then be followed with a version number, serial
number, or whatever."
  (format t "Warning, this program complements the characters! Use it only for Lambda s")
  (let ((offset-in-config-prom (- general-part-number-begin lambda-config-prom-base-address)))
    (dotimes (address 512.)		 
      (aset 0 config-prom address))
    (dotimes (index (string-length string))
      (aset (logxor (aref string index) 377) config-prom (+ index offset-in-config-prom)))
    (aset 377 config-prom (string-length string))))

(defun make-medium-color-config-prom (&optional (string "LMI MEDIUM COLOR"))
  "Fill the array CONFIG-PROM with the given string in preparation for programming
a 74S472 prom for the medium color.  The string should start with all of the letters of
the variable MEDIUM-COLOR-STRING, and may then be followed with a version number, serial
number, or whatever."
  (let ((offset-in-config-prom (- general-part-number-begin lambda-config-prom-base-address)))
    (dotimes (address 512.)		 
      (aset 0 config-prom address))
    (dotimes (index (string-length string))
      (aset (aref string index) config-prom (+ index offset-in-config-prom)))
    (aset 0 config-prom (string-length string))))


;set base pointer to the whole thing.
; it is on the memory card in the highest numbered slot
; Then, the structure is on the last page of that card, however big it is.
; (and by the way, the other communication pages are the 3 pages before that)
(defun set-configuration-pointer ()
  (let (slot size-in-pages)
    (dotimes (i 20) ;sys-conf is always in "local" nubus
      (cond ((string-equal "RAM" (string (car (aref nubus-configuration-array i)))
			   :start1 0 :start2 0 :end1 3 :end2 3)
	     (setq slot i)
 	     )))
    (cond ((null slot)
	   (format t "~&Warning: couldn't find any memory boards!")
	   (setq *configuration-pointer* nil)
	   )
	  ((not (sharestruct-valid-p))
	   (format t "~%Warning: sharestruct not valid, not setting up *configuration-pointer*")
	   (setq *configuration-pointer* nil))
	  (t
	   (setq size-in-pages
		 (selectq (car (aref nubus-configuration-array slot))
		   (ram-128k 1000)
		   (ram-512k 4000)
		   (ram-1024k 10000)
		   (t (ferror nil "unknown memory"))))
	   (setq *configuration-pointer*
		 (+ #xf0000000 (ash slot 24.)
		    (* 1024. (1- size-in-pages))))))))

;NB this one changes it in actual nubus memory.
(defun change-processor-switches-in-sys-conf (proc-conf-pointer l)
  (declare (special %processor-conf-starting-processor-switches))
  (do ((ps (send *proc* :bus-read-unsafe
		 (+ proc-conf-pointer
		    (* 4 %processor-conf-starting-processor-switches))))
       (x l (cddr l)))
      ((null x)
       (send *proc* :bus-write-unsafe
	     (+ proc-conf-pointer
		(* 4 %processor-conf-starting-processor-switches))
	     ps))
    (setq ps (dpb (cadr x) (symeval (car x)) ps))
    ))

(defun print-processor-switches-data (x)
  (do ((bit-list lambda-processor-switches-bits (cddr bit-list)))
      ((null bit-list))
    (format t "~&~s: ~o" (car bit-list) (ldb (symeval (car bit-list)) x))))

(defun print-processor-switches-from-sys-conf ()
  (declare (special %processor-conf-starting-processor-switches))
  (print-processor-switches-data 
    (bus-read (+ (send *proc* :proc-conf-bus-address)
		 (* 4 %processor-conf-starting-processor-switches)))))

(defun print-conf-structure ()
  (format t "~&*configuration-pointer* = #x~16r" *configuration-pointer*)
  (format t "~&system-configuration-qs:")
  (dolist (x system-configuration-qs)
    (format t "~&#x~16,8r: ~a:~40t~o"
	    (+ *configuration-pointer* (* (symeval x) 4))
	    x
	    (bus-read (+ *configuration-pointer* (* (symeval x) 4)))))
  (format t "~2&processors:")
  (let ((sys-conf-size (bus-read (+ *configuration-pointer*
				       (* %system-configuration-size 4))))
	(n-procs (bus-read (+ *configuration-pointer*
				 (* %system-configuration-number-of-processors 4))))
	(proc-size (bus-read (+ *configuration-pointer*
				   (* %system-configuration-processor-block-size 4)))))
    (dotimes (n n-procs)
      (let ((proc-p (+ *configuration-pointer* (* 4 sys-conf-size) (* 4 n proc-size))))
	(format t "~2&processor ~d; conf address = ~o ~:*(#x~16r)" n proc-p)
	(dolist (x processor-configuration-qs)
	  (format t "~&~8t#x~16,8r: ~a:~40t~o ~:*~16r"
		  (+ proc-p (* (symeval x) 4))
		  x
		  (bus-read (+ proc-p (* (symeval x) 4)))))))))

;defstruct for processor moved to diag-system

(defconst processor-variables
	  '(
	    lam-low-level-flag
	    lam-passive-save-valid
	    lam-full-save-valid
	    lam-running
	    lam-running-check-parity
	    lam-saved-opcs-valid
	    lam-saved-hptr
	    lam-noop-flag
	    lam-saved-pdl-buffer-index
	    lam-saved-micro-stack-ptr
	    lam-saved-level-1-map-loc-0
	    lam-saved-ir
	    lam-saved-pc
	    lam-saved-mfobus
	    lam-vma-changed-flag
	    lam-saved-vma
	    lam-saved-md
	    lam-saved-map-and-fault-status
	    lam-saved-parity-enables
	    lam-saved-parity-vector
	    lam-breakpoint-list
	    lam-temporary-breakpoint-list
	    default-parity-enable-list
	    check-parity
	    ))

(defvar *all-procs* nil)	;list of processor instances.
(defvar *proc* nil)

(defvar lam-phys-adr-convert 0 
  "xor this is a 32. bit phys adr to convert from cadr phys adr to current proc phys adr")

(defun select-processor-to-debug (&optional selection)
  (when *proc*
    (save-variables-to-current-processor)
    (if (send *proc* :disk-share-mode) (remove-share-iopb))	;if any
    )
  (setq *proc* nil)
  (do ()
      (*proc*
	(format t "~&Selecting processor in slot ~o"
		(send *proc* :slot)))
    (cond ((= (length *all-procs*) 0)
	   (ferror nil "no lambdas"))
	  ((= (length *all-procs*) 1)
	   (setq *proc* (car *all-procs*)))
	  (selection
	   (dolist (p *all-procs* (setq selection nil))
	     (cond ((or (eq selection p)
			(and (numberp selection)
			     (= selection (funcall p :slot))))
		    (setq *proc* p)
		    (return)))))
	  (t
	   (setq *proc*
		 (tv:menu-choose
		   (mapcar #'(lambda (x)
			       (list (format nil "Slot ~d (~s) ~S"
					     (funcall x :slot)
					     (funcall x :prom-string)
					     (processor-host-name x))
				     x))
			   *all-procs*)
		   "Choose a lambda")))))
  (set-variables-from-current-processor)
  )


(DEFUN PROCESSOR-HOST-NAME (X)
  (COND ((SEND-IF-HANDLES X :PROC-CONF-POINTER)
	 (let ((H (SI:GET-HOST-FROM-ADDRESS (SI:%PROCESSOR-CONF-CHAOS-ADDRESS (SEND X :PROC-CONF-POINTER))
				       :CHAOS)))
	   (IF H (send h :name) "unknown")))
	('else
	 "unknown")))
	 

(defun save-variables-to-current-processor ()
  (let ((plist nil))
    (dolist (var processor-variables)
      (when (boundp var)
	(putprop (locf plist) (symeval var) var)))
    (send *proc* :set-proc-variables-to-switch plist))
  (let ((saved-opcs-array
	  (cond ((send *proc* :saved-opcs))
		(t (make-array (- raopce raopco))))))
    (copy-opcs lam-saved-opcs saved-opcs-array)
    (send *proc* :set-saved-opcs saved-opcs-array))
  (let ((saved-micro-stack-array
	  (cond ((send *proc* :saved-micro-stack))
		(t (make-array 256.)))))
    (if lam-micro-stack (copy-array-contents lam-micro-stack saved-micro-stack-array))
    (send *proc* :set-saved-micro-stack saved-micro-stack-array))
  )

(defun copy-opcs (from to)
  (copy-array-contents from to))

(defun set-variables-from-current-processor ()
  (setq current-processor-type (send *proc* :proc-type))
 (setup-common-symbols (send *proc* :proc-type))  ;defined in lambda-diag;common-symbols.
 (cond ((< (send *proc* :major-version))
	(setq LAM-UINST-DESC LAM-UINST-DESC-lambda))
       (t
	(setq LAM-UINST-DESC LAM-UINST-DESC-lambda-hh)))
  (setq lam-phys-adr-convert (if (< (send *proc* :rg-slot) 20) 0 #x10000000))
  ;(setq *proc-configuration-pointer* (send *proc* :proc-conf-pointer))
  ;  (initialize-rg-slot nil)			;sets major and minor version numbers
;  (setq tv-slot (funcall *proc* :tv-slot))
  
  (do ((p (send *proc* :proc-variables-to-switch) (cddr p)))
      ((null p))
    (set (car p) (cadr p)))
  (if (send *proc* :saved-opcs)
      (copy-opcs (send *proc* :saved-opcs) lam-saved-opcs))
  (setq lam-micro-stack (send *proc* :saved-micro-stack))

  (if (send *proc* :disk-controller-type)
      (initialize-disk-control))    ;do this for each processor since iopb must point to
		;640, etc for this processor.
  (format t "~&i don't know how to restore the following state:")
  (format t "~&   symbol table used by this processor")
  (qf-clear-cache nil)
  nil
  )

(defun 2x2-setup ()
  (cond ((not (eq current-processor-type :lambda))
	 (lambda-mode)))
  (cond (lam-full-save-valid
	 (cond ((y-or-n-p "LAM has a saved processor state, do you want to restore it?")
		(lam-full-restore)))))
  (set-all-procs-list-from-local-conf)
  (setq *proc* nil)
  (select-processor-to-debug)
  (setq lam-full-save-valid nil)
  (setq lam-passive-save-valid nil)
  (qf-clear-cache t)
  (lam))

(defun bus-address-of-sys-conf-structure (struct)
  (logand 37777777777
	  (si:virtual-to-local-phys
	    (%p-contents-offset struct (si:array-data-offset struct)))))

;use this for 2x2, etc.
(defun set-all-procs-list-from-local-conf ()
  (setq *all-procs* nil)
  (dolist (op si:*other-processors*)
    (cond ((not (eq op si:*my-op*))
	   (add-proc-to-all-procs-if-lambda
	     (si:op-proc-conf op)
	     (bus-address-of-sys-conf-structure
	       (si:op-proc-conf op))
	     'lambda-via-local-access
	     'local))))
  (dolist (*proc* *all-procs*)
    (send *proc* :set-prom-string-and-lambda-version)))

(defun add-proc-to-all-procs-if-lambda
       (proc-conf proc-conf-bus-address flavor disk-type)
  (cond ((= 1 (si:%processor-conf-processor-type proc-conf))
	 (let* (($slot (si:%processor-conf-slot-number proc-conf))
		($prom-string nil)	;can read bus yet because *proc* not set up!
		($tv-slot (si:%processor-conf-vcmem-slot proc-conf))
		($memory-configuration (get-memory-configuration-from-local-proc-conf proc-conf))
		($disk-share-mode t)
		($disk-controller-type 'interphase)
		($disk-type disk-type)
		($proc-type :lambda)
		($proc (make-instance flavor
				      :rg-slot $slot
				      :prom-string $prom-string
				      :major-version nil
				      :minor-version nil
				      :tv-slot $tv-slot
				      :disk-controller-type $disk-controller-type
				      :disk-share-mode $disk-share-mode
				      :disk-type $disk-type
				      :memory-configuration-list $memory-configuration
				      :proc-type $proc-type
				      :proc-conf-pointer proc-conf
				      :proc-conf-bus-address proc-conf-bus-address)))
	   (setq *all-procs* (nconc *all-procs* (list $proc)))))))

(defvar remote-sys-conf nil)

(defun get-remote-sys-conf-array (sys-conf-array configuration-bus-address)
  (let* ((config-offset-on-board (dpb 0 (byte 8 24.) configuration-bus-address))
	 (size-in-halfwords (floor (- (^ 2 (haulong config-offset-on-board))
				      config-offset-on-board)
				   2)))
    (if (> size-in-halfwords 2048.)			;just a "reasonableness" check
	(ferror nil "conf structure too large"))
    
    (cond ((or (null sys-conf-array)
	       (not (= (array-length sys-conf-array) size-in-halfwords)))
	   (setq sys-conf-array (make-array size-in-halfwords
					    :type :art-16b))))

    (do ((adr configuration-bus-address (+ adr 4))
	 (offset 0 (+ offset 2)))
	((>= offset size-in-halfwords))
      (let ((data (bus-read adr)))
	(aset (ldb (byte 16. 0) data) sys-conf-array offset)
	(aset (ldb (byte 16. 16.) data) sys-conf-array (1+ offset))))
    sys-conf-array))

(defun set-all-procs-from-remote-conf ()
  (setq *all-procs* nil)
  (set-configuration-pointer)
  (setq remote-sys-conf (get-remote-sys-conf-array remote-sys-conf *configuration-pointer*))

  (do ((offset (si:%system-configuration-size remote-sys-conf)
	       (+ offset (si:%system-configuration-processor-block-size remote-sys-conf)))
       (proc-number 0 (1+ proc-number)))
      ((or ( proc-number (si:%system-configuration-number-of-processors remote-sys-conf))
	   ( (+ offset (si:%system-configuration-processor-block-size remote-sys-conf))
	      page-size)))
    (let ((proc-conf (make-array (* 2 page-size)
				 :type :art-16b
				 :displaced-to remote-sys-conf
				 :displaced-index-offset
				 (* offset 2))))
      (if (not (= *configuration-pointer*
		  (dpb (aref proc-conf 1)
		       (byte 16. 16.)
		       (aref proc-conf 0))))
	  (ferror nil "bad conf structure"))

      (add-proc-to-all-procs-if-lambda proc-conf
				       (+ *configuration-pointer* (* 4 offset))
				       'lambda-via-burr-brown 'unknown)
      ))
  (dolist (*proc* *all-procs*)
    (send *proc* :set-prom-string-and-lambda-version)))

(defun 2x2-setup ()
  (ferror nil "obsolete - use (setup)")
  (cond ((not (eq current-processor-type :lambda))
	 (lambda-mode)))
  (cond (lam-full-save-valid
	 (cond ((y-or-n-p "LAM has a saved processor state, do you want to restore it?")
		(lam-full-restore)))))
  (set-all-procs-list-from-local-conf)
  (setq *proc* nil)
  (select-processor-to-debug)
  (setq lam-full-save-valid nil)
  (setq lam-passive-save-valid nil)
  (qf-clear-cache t)
  (lam))


(defun setup (&optional (get-configuration t))
  (setq tram-location-3000 nil)
  (setq lam-passive-save-valid nil)
  (setq lam-full-save-valid nil)
 ;  (setq *share-mode* t)
 ;  (setq *use-configuration-structure* t)    ;obsolete
;  (setq mem-slot nil)
  (qf-clear-cache t)
 ;  (setq cdr-next-is-0 t)		;these should be set automatically now. --rg.
 ;  (setq his-system-version-override 105.)
  (qf-setup-q-fields t)
 ;  (setup-for-new-page-hash-table)
  (let* ((interface (fquery '(:choices (((:burr-brown "Burr Brown") #/b)
					((:local "Local") #/l)
					((:serial "Serial") #/s)
					))
			    "~&Type of interface: "))
	 (processor (cond ((eq interface :local)
			   :lambda)
			  (t
			   (fquery '(:choices (((:explorer "Explorer") #/e)
					       ((:lambda "Lambda") #/l)
					       ))
				   "~&Type of processor: ")))))
    (cond ((null (y-or-n-p "~2&A ~a via ~a ? " processor interface))
	   (return-from setup nil)))
    (ecase interface
      (:burr-brown
       (setq bb-address (choose-a-burr-brown))
       (setq *proc* (make-instance 'lambda-via-burr-brown))  ;dummy until have real thing below.
       (send *proc* :interface-reset))
      (:serial
       (selectq processor
	 (:lambda
	  (setq *proc* (make-instance 'lambda-via-lmi-serial))
	  (send *proc* :interface-reset))))
      (:local)
      )

    (when get-configuration
      (ecase interface
	(:burr-brown
	 (ecase processor
	   (:lambda
	     (setup-nubus-configuration)
	     (set-configuration-pointer)	;depends on nubus-configuration, above.
	    )
	   (:explorer)
	   ))
	(:serial
	 (ecase processor
	   (:lambda
	    (funcall *proc* :setup-nubus-configuration-and-configuration-pointer))
	   (:explorer)
	   ))
	(:local)
	))
    
    (ecase processor
      (:explorer
       (explorer-mode)
       (setq *proc* (make-instance
		      (selectq interface
			(:burr-brown 'explorer-via-ti-serial-with-nubus-from-burr-brown)
			(:serial 'explorer-via-ti-serial)
			(otherwise (ferror nil "Cant hack explorer via this interface")))
		      ;;fill in page-band-unit in full-save
		      :proc-type :explorer))
       (exp-serial-setup)
       )
      (:lambda
       (lambda-mode)
       (ecase interface
	 (:burr-brown
	  (cond ((null *configuration-pointer*)
		 (setq *all-procs*
		       (list (make-instance
				 'lambda-via-burr-brown
				 :rg-slot (or (getf *special-setup-slots* :rg-slot) 0)
				 :disk-controller-type nil
				 :disk-type 'eagle
				 :disk-share-mode t
				 :proc-type :lambda
				 :memory-configuration-list nil
				 :major-version lambda-major-version-number
				 :minor-version lambda-minor-version-number
				 :proc-conf-pointer (make-array (* 2 page-size)
								:type :art-16b
								)
				 :tv-slot (or (getf *special-setup-slots* :tv-slot) 0)
				 :page-band-unit 0
				 ))))
		(t	  
		 (set-all-procs-from-remote-conf))))
	 (:local
	  (set-all-procs-list-from-local-conf))
	 (:serial
	  (set-all-procs-list-from-serial-conf)))
       (setq *proc* nil)
       (select-processor-to-debug)
       )
      )
    
    (ecase interface
      (:burr-brown
       (ecase processor
	 (:lambda
	  (setup-for-disk))
	 (:explorer)))
      (:serial)
      (:local))
    )
  (setq izero-good-parity (compute-parity-for-ireg 0))
  )

(defvar *possible-burr-brown-interfaces*
	'((1 "BURR-BROWN-DEBUG-MASTER-1:")
	  (2 "BURR-BROWN-DEBUG-MASTER-2:")))

(defun choose-a-burr-brown ()
  ;; This just opens the device and gets its internal multibus address.
  ;; Eventually the burr-brown code should be rewritten to use the device
  ;; driver abstractly in much the same way that the serial code does.
  ;; There has got to be a better way to get efficiency than huge amounts of
  ;; open-coding.
  (let ((choices (mapcar #'(lambda (l)
			    (list (car l) (cadr l) (send (fs:parse-pathname (cadr l)) :host)))
			*possible-burr-brown-interfaces*)))
    (setq choices (subset #'(lambda (x)
			      (not (eq (send (caddr x) :owner) :not-on-bus)))
			  choices))
    (flet ((help (stream ignore ignore)
		 (format stream "~&Available burr brown debug masters:~%")
		 (dolist (c choices)
		   (format stream "~D ~S~%" (car c) (caddr c)))))
      (help *query-io* choices nil)
      (WITH-OPEN-FILE (DEVICE (cond ((= (length choices) 1)
				     (cadr (car choices)))
				    (t
				     (fquery `(:help-function
						,#'help
						:type :tyi
						:choices
						,(mapcar #'(lambda (c)
							     (list (list (cadr c)
									 (cadr c))
								   (digit-char (car c))))
							 choices))
					     "Please pick an interface:"))))
	(send DEVICE :MULTIBUS-ADDRESS))))
  )

(defun share-already-up (&optional get-configuration)
  get-configuration
  (ferror nil "obsolete - use (setup)")
;  (if (not (eq current-processor-type :lambda))
;      (lambda-mode))
;  ;;need to have something in *proc* to do any nubus accesses
;  (setq *proc* (make-instance 'lambda-via-burr-brown
;			      :proc-type :lambda
;			      ))
      
;  (if get-configuration
;      (make-nubus-configuration-array))
;  (setq tram-location-3000 nil)
;  (setq lam-passive-save-valid nil
;	lam-full-save-valid nil)
; ;  (setq *share-mode* (not (zerop (ldb (byte 20. 0)
; ;				      (read-8086-multibus-address sharestruct-ptr)))))
; ;  (setq *use-configuration-structure* t)
;  (get-ucode-from-sys)
;  (setq mem-slot nil)
;  (set-configuration-pointer)
;  (set-up-all-processors-list-from-conf)
;  (setq *proc* nil)
;  (select-processor-to-debug)
;  (setup-for-disk)
  )

(defun flush-state ()
  (setq lam-full-save-valid nil)
  (setq lam-passive-save-valid nil)
  (qf-clear-cache t))


(defun test-spy-interface (&optional (address #xfe000000))
  (do-forever
    (tyo #/.)
    (dotimes (i 32.)
      (bus-write address (ash 1 i))
      (bus-write (+ address 4) 55555555)
      (let ((r (bus-read address)))
	(cond ((not (= r (ash 1 i)))
	       (ferror nil "wrote ~o read ~o" (ash 1 i) r)))))
    (dotimes (i 32.)
      (let ((w (logand 37777777777 (dpb 0 (byte 1 i) -1))))
	(bus-write address w)
	(bus-write (+ address 4) 5555555)
	(let ((r (bus-read address)))
	  (cond ((not (= r w))
		 (ferror nil "wrote ~o read ~o" w r))))))))

(defun stop-chaos-net ()
  (net:deconfigure))