;;; -*- Mode: Lisp -*-
;;;
;;; (c) Copyright 1984 - Lisp Machine, Inc.
;;;


; This file implements the diagnostic window.
; Currently, the diagnostic window is simply a lisp
; listener.  Eventually, it should automatically load
; in the diagnostic code upon being activated.

; When the right mouse button is pressed in the region
; of the diagnostic window, a pop-up menu appears
; with several options for doing various things useful
; in doing hardware diagnostics.

(defun make-diagnostic-window ()
   (tv:make-window 'diagnostic-window
                   ':edges-from ':mouse
		   ':expose-p t))

(defflavor diagnostic-window ()
	   (tv:lisp-listener))

(defmethod (diagnostic-window :mouse-click)
	   (mchar x y)
  (tv:menu-choose 
      '(("display a register"
	:eval
	(display-register))
       ("do frob1"
	:eval
	(princ "frob1 done")))))

; display-register will prompt the user for the name of
; a register.   He can either choose one of the registers
; in the "special register list", or he can enter the address 
; of any register in the machine.  

(defun display-register ()
   (let ((chosen-register
	   (tv:menu-choose
	     (loop with collist = '("Any Register")
	           for entry in register-list
		   do (setq collist (cons entry collist))
		   finally (return collist)))))

     (cond ((equal chosen-register '"Any Register")
	    (setq chosen-register
		  (prompt-for-register-name))
	    (create-window-for-register chosen-register)
	    (expose-register-window chosen-register))
	   (t
	    (create-window-for-special-register chosen-register)
	    (expose-special-register-window chosen-register)))))

; stubs
(defun prompt-for-register-name ()
   (princ "prompt-for-register-name"))

(defun create-window-for-register (x)
   (princ "create-window-for-register"))

(defun expose-register-window (x)
   (princ "expose-register-window"))

(defun create-window-for-special-register (x)
   (princ "create-window-for-special-register"))

(defun expose-special-register-window (x)
   (princ "expose-special-register-window"))

(setq register-list 
   '(("register1")
     ("register2")))