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

;;; Youcef. 01/06/86.
;;;
;;; This will provide an window interface for the hardware diagnostics.
;;;


(defflavor rack
	   ((nubus-configuration nil)
	    (current-board-to-debug nil)
	    (list-of-processors-in-rack nil))
	   ()
  :gettable-instance-variables
  :inittable-instance-variables
  :settable-instance-variables)

(defflavor debugger-rack
	   ((debug-boards (list '("Local" :LOCAL) '("Serial" :SERIAL) '("Burr Brown" :BURR-BROWN)))
	    (boards-in-foreign-rack nil)
	    (list-of-slot-numbers-with-boards nil)	; maintains a list of boards with slot numbers.
	    (header nil)
	    (assoc-list-for-lines-dependencies nil)
	    (bus-configuration nil))
	   (rack)
  :gettable-instance-variables
  :inittable-instance-variables
  :settable-instance-variables)

;;
;; this is the structure of a debugged type of structure. This could also represent the debug
;; path we are dealing with. A rack can have more than one processor to debug or more than one
;; board to work on.
;;

(defflavor debugged-rack
	   ((boards-to-debug NIL)
	    (current-board NIL))
	   (rack)
  :gettable-instance-variables
  :inittable-instance-variables
  :settable-instance-variables)
  

(setq *debugger-rack* (make-instance 'debugger-rack))
;;
;; the setup window process then ask the user first to select the hardware interface to be
;; used for the debugging. Once that has been selected, the different options on it are
;; added to the window (information about that particular interface such as slot number, length
;; of cables and so on.. Upon selection of the slot number is more that one of such a debug
;; interface is present, the system adds the lines of which bard on the other rack we want to
;; work on. The selection will be only on board that exists on the foreign rack (or the local one
;; if it is used by :local or :serial options.
;;
;;

;;
;;   Debug boards on a nubus can be :
;;                                  Burr-brown cards
;;                                  none case where we are using a 2X2. (local)
;;                                  SDU
;;                                  LMI-DEBUG
;;                                  
;;  Two of those (Local and SDU) are all the time there.
;;

(defconst board-types '(unknown none lambda mc68000 sdu vcmem half-meg
				two-meg medium-color buscoupler ti-eight-meg
				lmi-four-meg lmi-sixteen-meg quad-video
				nubus-disk lmi-eight-meg lambda-avp lmi-twelve-meg DUMMY-NIL NU-DEBUG))

(defmethod (debugger-rack :get-configuration) ()
  ;; use Bob Powel's code to read the configuration file from disk and build a list structure
  ;; configuration to use here.
  ;;
  (setq list-of-slot-numbers-with-boards NIL)
  (sdu:set-up-config-arrays)
  (let ((list-of-boards (sdu:get-list-of-boards))
	(slot-number 0)
	(any-lmi-new-debug-cards? nil))
    ;; process each known board of this rack.
    (dolist (board list-of-boards)
      (SELECTOR (nth (sdu:ps-board-type board) board-types) STRING-EQUAL
	("NONE")
	(("LMI-LAMBDA" "LAMBDA") (push `(,slot-number :LAMBDA) list-of-slot-numbers-with-boards))
	("UNKNOWN" (push `(,slot-number :UNKNOWN) list-of-slot-numbers-with-boards))
	("MC68000" (push `(,slot-number :MC68000) list-of-slot-numbers-with-boards))
	("SDU" (push `(,slot-number :SDU) list-of-slot-numbers-with-boards))
	("HALF-MEG" (push `(,slot-number :HALF-MEG) list-of-slot-numbers-with-boards))
	("two-meg" (push `(,slot-number :TWO-MEG) list-of-slot-numbers-with-boards))
	("medium-color" (push `(,slot-number :MEDIUM-RES-COLOR) list-of-slot-numbers-with-boards))
	("NU-DEBUG" (push `(,slot-number :LMI-DEBUG) list-of-slot-numbers-with-boards)
		      (setq any-lmi-new-debug-cards? T))
	("ti-eight-meg" (push `(,slot-number :TI-EIGHT-MEG) list-of-slot-numbers-with-boards))
	("lmi-four-meg" (push `(,slot-number :LMI-FOUR-MEG) list-of-slot-numbers-with-boards))
	("VCMEM" (push `(,slot-number :VCMEM) list-of-slot-numbers-with-boards))
	("lmi-sixteen-meg" (push `(,slot-number :LMI-SIXTEEN-MEG) list-of-slot-numbers-with-boards))
	("quad-video" (push `(,slot-number :QUAD) list-of-slot-numbers-with-boards))
	("nubus-disk" (push `(,slot-number :NUBUS-DISK) list-of-slot-numbers-with-boards))
	("lmi-eight-meg" (push `(,slot-number :LMI-EIGHT-MEG) list-of-slot-numbers-with-boards))
	("LMI-lambda-avp" (push `(,slot-number :AVP) list-of-slot-numbers-with-boards))
	("lmi-twelve-meg" (push `(,slot-number :LMI-TWELVE-MEG) list-of-slot-numbers-with-boards))
	)
      (setq slot-number (1+ slot-number))
      (and (> slot-number 15.) (return t))
      )
    (and any-lmi-new-debug-cards? (funcall-self :add-element-to-debug-boards `("LMI Debug" :LMI-DEBUG))))
  )


(defmethod (debugger-rack :get-debug-board-slot-numbers) (&aux return-list)
  (dolist (entry list-of-slot-numbers-with-boards)
    (and (equal (second entry) :LMI-DEBUG)
	 (push (list (format nil "~X" (first entry)) (first entry)) return-list)))
  return-list
  )

(defmethod (debugger-rack :add-element-to-debug-boards) (entry)
  (setq debug-boards (nconc debug-boards (ncons entry)))
  )

(defmethod (debugger-rack :delete-debug-board) (entry)
  (and (member entry debug-boards)
       (setq debug-boards (del 'equal entry debug-boards)))
  )

(defmethod (debugger-rack :add-foreign-board) (entry)
  (setq boards-in-foreign-rack (nconc boards-in-foreign-rack (ncons entry)))
  )

(defmethod (debugger-rack :delete-foreign-board) (entry)
  (and (member entry boards-in-foreign-rack)
       (setq boards-in-foreign-rack (delq entry boards-in-foreign-rack)))
  )

(defmethod (debugger-rack :setup) ()
  ;; clear window from previous knowledge.
  (funcall *menu-choose-window-for-set-up* :delete-all-elements)
  (when (not header)
    ;; create the lines for header.
    (push (create-line
	    "Choose board to debug" fonts:tr12i
	    `(("Menu for boards" :MENU-FOR-BOARDS))
	    `(SDU 15.)
	    fonts:tr12i fonts:tr12i NIL
	    'choose-a-board-to-debug :BOARD) header)
    ;; now make sure that we can access that line.
    (push (list :INTERFACE (first header))
	  *lines-to-delete-if-old-selection-is*)
    (push (create-line
	    "Type of interface" fonts:tr12i
	    debug-boards
	    NIL
	    fonts:tr12i fonts:tr12bi "Local"
	    'update-type-interface-line :INTERFACE) header))
  (dolist (line header)
    (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line)
    (add-lines-and-dependents (line-binding line))
    )
  (process-function-setup-environment-internal)
  )