;;; -*- Mode: LISP;  Package: TV;  Base: 8 -*-
;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; PEEK -- displays status information about the Lisp Machine

(DEFFLAVOR BASIC-PEEK ((NEEDS-REDISPLAY NIL) (MODE-ALIST))
   (SCROLL-MOUSE-MIXIN SCROLL-WINDOW-WITH-TYPEOUT)
  :SETTABLE-INSTANCE-VARIABLES
  :GETTABLE-INSTANCE-VARIABLES
  (:DEFAULT-INIT-PLIST :SAVE-BITS T
    		       :LABEL "Peek"
		       :TRUNCATION T)
  (:DOCUMENTATION :SPECIAL-PURPOSE "The actual peek window"))

(DEFMETHOD (BASIC-PEEK :NAME-FOR-SELECTION) ()
  (STRING-APPEND "Peek: " (LABEL-STRING LABEL)))

(DEFFLAVOR PEEK () (PROCESS-MIXIN TV:INITIALLY-INVISIBLE-MIXIN BASIC-PEEK)
  (:DOCUMENTATION :COMBINATION "Peek window with a process"))

(DEFMETHOD (PEEK :BEFORE :INIT) (IGNORE)
  (OR PROCESS (SETQ PROCESS '(PEEK-STANDALONE-TOP-LEVEL :SPECIAL-PDL-SIZE 4000
							:REGULAR-PDL-SIZE 10000))))

(COMPILE-FLAVOR-METHODS BASIC-PEEK PEEK)

(DECLARE (SPECIAL VALUE-ARRAY))

(DEFVAR PEEK-DEFAULT-MODE-ALIST NIL)

(DEFMACRO DEFINE-PEEK-MODE (FUNCTION CHARACTER DOCUMENTATION &OPTIONAL FUNCTION-P)
  `(DEFINE-PEEK-MODE-1 ',FUNCTION ,CHARACTER ,DOCUMENTATION ,FUNCTION-P))

(DEFUN DEFINE-PEEK-MODE-1 (FUNCTION CHARACTER DOCUMENTATION FUNCTION-P &AUX ELEM)
  (AND (SETQ ELEM (ASSOC CHARACTER PEEK-DEFAULT-MODE-ALIST))
       (SETQ PEEK-DEFAULT-MODE-ALIST (DELQ ELEM PEEK-DEFAULT-MODE-ALIST)))
  (SETQ PEEK-DEFAULT-MODE-ALIST
	(NCONC PEEK-DEFAULT-MODE-ALIST
	       (NCONS (LIST CHARACTER FUNCTION DOCUMENTATION FUNCTION-P)))))

(DEFVAR PEEK-SLEEP-TIME 120.)

(DEFUN PEEK-SET-MODE (WINDOW MODE &REST ARGS)
  (COND ((SETQ MODE (ASSOC MODE (FUNCALL WINDOW ':MODE-ALIST)))
	 (IF (FOURTH MODE)
	     (LEXPR-FUNCALL (SECOND MODE) WINDOW ARGS)
	     (PEEK-ASSURE-NO-TYPEOUT WINDOW)
	     (FUNCALL WINDOW ':SET-LABEL (THIRD MODE))
	     (FUNCALL WINDOW ':SET-DISPLAY-ITEM (LEXPR-FUNCALL (SECOND MODE) ARGS)))
	 T)
	(T NIL)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-PEEK)
(DEFUN PEEK-MOUSE-CLICK (ITEM LEADER-TO-COMPLEMENT)
  (SETQ NEEDS-REDISPLAY T)
  (SETF (ARRAY-LEADER ITEM (+ SCROLL-ITEM-LEADER-OFFSET LEADER-TO-COMPLEMENT))
	(NOT (ARRAY-LEADER ITEM (+ SCROLL-ITEM-LEADER-OFFSET LEADER-TO-COMPLEMENT))))))

(DEFUN PEEK-STANDALONE-TOP-LEVEL (WINDOW)
  (*CATCH 'SYS:COMMAND-LEVEL
    (PROGN (FUNCALL WINDOW ':SET-MODE-ALIST PEEK-DEFAULT-MODE-ALIST)
	   (PEEK-TOP-LEVEL WINDOW "?")
	   (DO () (())
	     (FUNCALL WINDOW ':DESELECT T)
	     (PEEK-TOP-LEVEL WINDOW NIL))))
  (FUNCALL WINDOW ':BURY))

(DEFUN PEEK (&OPTIONAL (INITIAL-MODE "P") (WINDOW TERMINAL-IO))
  "The peek function itself -- window pushes terminal-io, and starts displaying
status information."
  (USING-RESOURCE (BIT-ARRAY BIT-ARRAYS)
    (WINDOW-BIND (WINDOW 'BASIC-PEEK ':BIT-ARRAY BIT-ARRAY)
      (FUNCALL WINDOW ':SET-MODE-ALIST PEEK-DEFAULT-MODE-ALIST)
      (*CATCH 'SYS:COMMAND-LEVEL (PEEK-TOP-LEVEL WINDOW INITIAL-MODE)))))

(DEFUN PEEK-TOP-LEVEL (WINDOW MODE)
  (COND-EVERY
    ((AND MODE (SYMBOLP MODE)) (SETQ MODE (GET-PNAME MODE)))
    ((STRINGP MODE) (SETQ MODE (AREF MODE 0)))
    ((NUMBERP MODE) (FUNCALL WINDOW ':FORCE-KBD-INPUT MODE)))
  (*CATCH 'SYS:COMMAND-LEVEL
    (DO ((SLEEP-TIME PEEK-SLEEP-TIME)
	 (WAKEUP-TIME (TIME-DIFFERENCE (TIME) (- PEEK-SLEEP-TIME)))
	 (TERMINAL-IO (FUNCALL WINDOW ':TYPEOUT-WINDOW))
	 (ARG)
	 (CHAR))
	(())
      (AND (TIME-LESSP WAKEUP-TIME (TIME))
	   (SETQ WAKEUP-TIME (TIME-DIFFERENCE (TIME) (- SLEEP-TIME))))
      (OR (= SLEEP-TIME 0)
	  (PROCESS-WAIT "Peek Timeout or TYI"
			#'(LAMBDA (TIME FLAG-LOC STREAM)
			    (OR (TIME-LESSP TIME (TIME))
				(CAR FLAG-LOC)
				(FUNCALL STREAM ':LISTEN)))
			WAKEUP-TIME
			(LOCATE-IN-INSTANCE WINDOW 'NEEDS-REDISPLAY)
			TERMINAL-IO))
      (DO ()
	  ((PROGN (PEEK-ASSURE-NO-TYPEOUT WINDOW)
		  (NULL (SETQ CHAR (FUNCALL TERMINAL-IO ':TYI-NO-HANG)))))
	(COND ((NUMBERP CHAR)
	       ;; Standard character, either accumulate arg or select new mode
	       (SETQ CHAR (CHAR-UPCASE CHAR))
	       (IF (OR (< CHAR #/0) (> CHAR #/9))
		   (COND ((PEEK-SET-MODE WINDOW CHAR ARG)
			  (SETQ ARG NIL))
			 (T
			  ;; Check for standard character assignments
			  (SELECTQ CHAR
			    ((#\HELP #/?)
			     (FUNCALL STANDARD-OUTPUT ':CLEAR-SCREEN)
			     (FORMAT T "Peek modes:~%~%")
			     (DOLIST (E (FUNCALL WINDOW ':MODE-ALIST))
			       (FORMAT T "~:@C~20T~A~%" (FIRST E) (THIRD E)))
			     (FORMAT T "Q~20TQuit~%")
			     (FORMAT T "nZ~20TSets sleep time between updates~%")
			     (FORMAT T "?~20TPrints this message~%")
			     (SETQ ARG NIL))
			    (#/Q
			     (*THROW 'SYS:COMMAND-LEVEL NIL))
			    (#/Z
			     (AND ARG (SETQ SLEEP-TIME ARG))
			     (SETQ ARG NIL))
			    (OTHERWISE (BEEP)))))
		   (OR ARG (SETQ ARG 0))
		   (SETQ ARG (+ (* 10. ARG) (- CHAR #/0)))))
	      ((LISTP CHAR)
	       ;; A special command (forced input, no doubt)
	       (SELECTQ (CAR CHAR)
		 (SUPDUP (SUPDUP (CADR CHAR)))
		 (TELNET (TELNET (CADR CHAR)))
		 (QSEND
		  (CHAOS:SEND-MSG (CADR CHAR))
		  (FUNCALL WINDOW ':SET-NEEDS-REDISPLAY T)
		  (FUNCALL TERMINAL-IO ':MAKE-COMPLETE))
		 (EH (EH (CADR CHAR)))
		 (OTHERWISE (BEEP)))
	       (SETQ ARG NIL))))
      (COND ((OR (FUNCALL WINDOW ':NEEDS-REDISPLAY) (TIME-LESSP WAKEUP-TIME (TIME)))
	     ;; We want to redisplay.  If have typeout, hang until user confirms.
	     (FUNCALL WINDOW ':SET-NEEDS-REDISPLAY NIL)
	     (FUNCALL WINDOW ':REDISPLAY))))))

(DEFUN PEEK-ASSURE-NO-TYPEOUT (WINDOW)
  (COND ((FUNCALL (SETQ WINDOW (FUNCALL WINDOW ':TYPEOUT-WINDOW)) ':INCOMPLETE-P)
	 (FORMAT T "~&Type any character to flush:")
	 (LET ((CHAR (FUNCALL TERMINAL-IO ':TYI)))
	   (FUNCALL WINDOW ':MAKE-COMPLETE)
	   (OR (= CHAR #\SPACE) (FUNCALL TERMINAL-IO ':UNTYI CHAR))))))

;;; Processes, meters
(DEFINE-PEEK-MODE PEEK-PROCESSES #/P "Active Processes")

(DEFUN PEEK-PROCESSES (IGNORE)
  "Shows state of all active processes."
  (LIST ()
	(SCROLL-PARSE-ITEM (FORMAT NIL "~30A~A" "Process Name" "State"))
	(SCROLL-PARSE-ITEM "")
	(SCROLL-MAINTAIN-LIST #'(LAMBDA () ALL-PROCESSES)
			      #'(LAMBDA (PROCESS)
				  (SCROLL-PARSE-ITEM
				    `(:MOUSE-ITEM
				       (NIL :EVAL (PEEK-PROCESS-MENU ',PROCESS 'ITEM 0)
					    :DOCUMENTATION
					    "Menu of useful things to do to this process.")
				       :STRING ,(PROCESS-NAME PROCESS) 30.)
				    `(:FUNCTION ,#'PEEK-WHOSTATE
						,(NCONS PROCESS))))
			      NIL
			      #'(LAMBDA (STATE)
				  (PROG ()
				    (RETURN (CAR STATE) (CDR STATE) (NULL (CDR STATE))))))
	(SCROLL-PARSE-ITEM "")
	(SCROLL-PARSE-ITEM "Clock Function List")
	(SCROLL-MAINTAIN-LIST #'(LAMBDA () SI:CLOCK-FUNCTION-LIST)
			      #'(LAMBDA (FUNC)
				  (SCROLL-PARSE-ITEM `(:STRING ,(GET-PNAME FUNC)))))))

(DEFUN PEEK-WHOSTATE (PROCESS)
  (COND ((SI:PROCESS-ARREST-REASONS PROCESS) "ARREST")
	((SI:PROCESS-RUN-REASONS PROCESS) (PROCESS-WHOSTATE PROCESS))
	(T "STOP")))

(DEFINE-PEEK-MODE PEEK-COUNTERS #/% "Statistics Counters")

(DEFUN PEEK-COUNTERS (IGNORE)
  "Statistics counters"
  (LIST ()
    (SCROLL-MAINTAIN-LIST #'(LAMBDA () SYS:A-MEMORY-COUNTER-BLOCK-NAMES)
			  #'(LAMBDA (COUNTER)
			      (SCROLL-PARSE-ITEM
				`(:STRING ,(STRING COUNTER) 35.)
				`(:FUNCTION READ-METER (,COUNTER) NIL ("~@15A" 10. T)))))))

;;; Memory

(DEFUN PEEK-MEMORY-HEADER ()
  (SCROLL-PARSE-ITEM
      "Physical memory: "
      `(:FUNCTION ,#'(LAMBDA (&AUX (VAL (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE)))
		       (SETF (VALUE 0) (// VAL 2000))
		       VAL)
		  NIL NIL (NIL 8.))
      `(:VALUE 0 NIL (" (~DK), "))
      "Free space: "
      `(:FUNCTION ,#'(LAMBDA (&AUX (VAL (SI:GET-FREE-SPACE-SIZE)))
		       (SETF (VALUE 0) (// VAL 2000))
		       VAL)
		  NIL NIL (NIL 8.))
      `(:VALUE 0 NIL (" (~DK)"))
      ", Wired pages "
      `(:FUNCTION ,#'(LAMBDA ()
		       (MULTIPLE-VALUE-BIND (N-WIRED-PAGES N-FIXED-WIRED-PAGES)
			   (SI:COUNT-WIRED-PAGES)
			 (SETF (VALUE 0) (- N-WIRED-PAGES N-FIXED-WIRED-PAGES))
			 (SETF (VALUE 1) (// N-WIRED-PAGES (// 2000 PAGE-SIZE)))
			 (SETF (VALUE 2) (\ N-WIRED-PAGES (// 2000 PAGE-SIZE)))
			 N-FIXED-WIRED-PAGES))
		  NIL NIL ("~D"))
      `(:VALUE 0 NIL ("+~D "))
      `(:VALUE 1 NIL ("(~D"))
      `(:VALUE 2 NIL ("~[~;.25~;.5~;.75~]K)"))))

(DEFINE-PEEK-MODE PEEK-AREAS #/A "Areas")

(DEFUN PEEK-AREAS (IGNORE)
  "Areas"
  (LIST ()
    (PEEK-MEMORY-HEADER)
    (SCROLL-PARSE-ITEM "")
    (SCROLL-MAINTAIN-LIST
      #'(LAMBDA () 0)
      #'(LAMBDA (AREA)
	  (LIST '(:PRE-PROCESS-FUNCTION PEEK-AREAS-REGION-DISPLAY)
	    (SCROLL-PARSE-ITEM
	      ':MOUSE-SELF '(NIL :EVAL (PEEK-MOUSE-CLICK 'SELF 0)
				 :DOCUMENTATION
				 "Insert//remove display of all regions in this area.")
	      ':LEADER `(NIL ,AREA)
	      `(:STRING ,(STRING (AREA-NAME AREA)) 40.)
	      `(:FUNCTION ,#'(LAMBDA (AREA)
			       (MULTIPLE-VALUE-BIND (LENGTH USED N-REGIONS)
				   (SI:ROOM-GET-AREA-LENGTH-USED AREA)
				 (SETF (VALUE 0) USED)
				 (SETF (VALUE 1) LENGTH)
				 (SETF (VALUE 2)
				       (COND ((ZEROP LENGTH) 0)
					     ((< LENGTH 40000)
					      (// (* 100. (- LENGTH USED)) LENGTH))
					     (T
					      (// (- LENGTH USED) (// LENGTH 100.)))))
				 N-REGIONS))
			  (,AREA) 15. ("(~D region~0G~P)"))
	      `(:VALUE 2 NIL ("~@3A% free, " 10. T))
	      `(:VALUE 0 NIL ("~O"))
	      `(:VALUE 1 NIL ("//~O used")))))
      NIL
      #'(LAMBDA (STATE)
	  (PROG (NEXT-ONE THIS-ONE
		  (LEN (ARRAY-LENGTH #'AREA-NAME)))
	    (DO ((I STATE (1+ I)))
		(( I LEN) NIL)
	      (COND ((AND (NULL THIS-ONE) (AREF #'AREA-NAME I))
		     (SETQ THIS-ONE I))
		    ((AND THIS-ONE (AREF #'AREA-NAME I))
		     (SETQ NEXT-ONE I)
		     (RETURN T))))
	    (RETURN THIS-ONE NEXT-ONE (NULL NEXT-ONE)))))))

(DEFUN PEEK-AREAS-REGION-DISPLAY (ITEM)
  "Handles adding/deleting of the region display when a mouse button is clicked."
  (COND ((NULL (ARRAY-LEADER (CADR ITEM) SCROLL-ITEM-LEADER-OFFSET)))
	 ;; Clicked on this item, need to complement state
	((= (LENGTH ITEM) 2)
	 ;; If aren't displaying regions now, display them
	 (RPLACD (CDR ITEM)
		 (NCONS
		   (SCROLL-MAINTAIN-LIST
		   `(LAMBDA ()
		      (AREA-REGION-LIST (ARRAY-LEADER ',(FIRST (SCROLL-ITEMS ITEM))
						      (1+ SCROLL-ITEM-LEADER-OFFSET))))
		   #'(LAMBDA (REGION)
		       (SCROLL-PARSE-ITEM
			`(:STRING
			  ,(FORMAT NIL "  #~O: Origin ~O, Length ~O, "
				       REGION
				       (REGION-ORIGIN-TRUE-VALUE REGION)
				       (REGION-LENGTH REGION)))
			`(:FUNCTION ,#'REGION-FREE-POINTER (,REGION) NIL ("Used ~O, "))
			`(:FUNCTION ,#'REGION-GC-POINTER (,REGION) NIL ("GC ~O, "))
			`(:FUNCTION ,#'(LAMBDA (REGION &AUX BITS)
					(SETQ BITS (REGION-BITS REGION))
					(SETF (VALUE 0)
					      (NTH (LDB %%REGION-SPACE-TYPE BITS)
						   '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5
						     NEW6 STATIC FIXED EXTRA-PDL COPY
						     "TYPE=15" "TYPE=16" "TYPE=17")))
					(SETF (VALUE 1) (LDB %%REGION-MAP-BITS BITS))
					(SETF (VALUE 2) (LDB %%REGION-SCAVENGE-ENABLE BITS))
					(NTH (LDB %%REGION-REPRESENTATION-TYPE BITS)
					     '(LIST STRUC "REP=2" "REP=3")))
				    (,REGION) NIL ("Type ~A "))
			`(:VALUE 0 NIL ("~A, "))
			`(:VALUE 1 NIL ("Map ~O, "))
			`(:VALUE 2 NIL ("~[NoScav~;Scav~]"))))
		   NIL
		   #'(LAMBDA (STATE)
		       (PROG ()
			 (RETURN STATE (REGION-LIST-THREAD STATE)
				 (MINUSP (REGION-LIST-THREAD STATE)))))))))
	(T (RPLACD (CDR ITEM) NIL)))
  (SETF (ARRAY-LEADER (CADR ITEM) SCROLL-ITEM-LEADER-OFFSET) NIL))

;;; File system status
(DEFINE-PEEK-MODE PEEK-FILE-SYSTEM #/F "File System Status")

(DEFUN PEEK-FILE-SYSTEM (IGNORE)
  "Display status of file system"
  (SCROLL-MAINTAIN-LIST 
    #'(LAMBDA () FS:*PATHNAME-HOST-LIST*)
    #'(LAMBDA (HOST)
	(APPEND '(())
	  (FUNCALL HOST ':PEEK-FILE-SYSTEM-HEADER)
	  (FUNCALL HOST ':PEEK-FILE-SYSTEM)))))

(DEFMETHOD (SI:FILE-DATA-STREAM-MIXIN :PEEK-FILE-SYSTEM) (&OPTIONAL (INDENT 0) &AUX DIRECTION)
  "Returns a scroll item describing a stream"
  (TV:SCROLL-PARSE-ITEM
    ':MOUSE `(NIL :EVAL (PEEK-FILE-SYSTEM-STREAM-MENU ',SELF)
		  :DOCUMENTATION "Menu of useful things to do to this open file.")
    (AND ( INDENT 0) (FORMAT NIL "~VX" INDENT))
    (SELECTQ (SETQ DIRECTION (FUNCALL-SELF ':DIRECTION))
      (:INPUT "Input ")
      (:OUTPUT "Output ")
      (OTHERWISE "Direction? "))
    (FUNCALL (FUNCALL-SELF ':PATHNAME) ':STRING-FOR-PRINTING)
    (IF (FUNCALL-SELF ':CHARACTERS)
	", Character, " ", Binary, ")
    `(:FUNCTION ,#'(LAMBDA (STREAM)
		     (SETF (TV:VALUE 0) (FUNCALL STREAM ':READ-POINTER))
		     (TV:VALUE 0))
		(,SELF) NIL ("~D"))
    (AND (EQ DIRECTION ':INPUT)
	 `(:FUNCTION ,#'(LAMBDA (STREAM)
			  (LET ((LENGTH (FUNCALL STREAM ':LENGTH)))
			    (AND LENGTH (NOT (ZEROP LENGTH))
				 (// (* 100. (TV:VALUE 0)) LENGTH))))
		     (,SELF) NIL ("~@[ (~D%)~]")))
    " bytes"))

(DEFUN PEEK-FILE-SYSTEM-STREAM-MENU (STREAM)
  (PROCESS-RUN-FUNCTION "Peek File System Menu"
    #'(LAMBDA (STREAM)
	(MENU-CHOOSE `(("Close" :EVAL (FUNCALL ',STREAM ':CLOSE)
				:DOCUMENTATION "Close selected file (normally).")
		       ("Abort" :EVAL (FUNCALL ',STREAM ':CLOSE ':ABORT)
				:DOCUMENTATION "Close selected file (aborts writing).")
		       ("Delete" :EVAL (FUNCALL ',STREAM ':DELETE)
				 :DOCUMENTATION "Delete selected file, but don't close it.")
		       )))
    STREAM))

(DEFUN PEEK-PROCESS-MENU (&REST ARGS)
  (LEXPR-FUNCALL #'PROCESS-RUN-FUNCTION "Peek Process Menu"
		 SELF ':FUNCALL-INSIDE-YOURSELF #'PEEK-PROCESS-MENU-INTERNAL ARGS))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-PEEK)
(DEFUN PEEK-PROCESS-MENU-INTERNAL (PROCESS &REST IGNORE &AUX CHOICE)
  "Menu for interesting operations on processes in a peek display"
  (LET ((TERMINAL-IO TYPEOUT-WINDOW))
    (SETQ CHOICE (MENU-CHOOSE
		   '(("Arrest" :VALUE PROCESS-ARREST
		      :DOCUMENTATION "Arrest the selected process.  Undone by Un-Arrest.")
		     ("Un-Arrest" :VALUE PROCESS-UN-ARREST
		      :DOCUMENTATION "Un-Arrest the selected process.  Complement of Arrest.")
		     ("Flush" :VALUE PROCESS-FLUSH
		      :DOCUMENTATION
		      "Unwind the selected process' stack and make it unrunnable.")
		     ("Reset" :VALUE PROCESS-RESET
		      :DOCUMENTATION "Reset the selected process.")
		     ("EH" :VALUE PROCESS-EH
		      :DOCUMENTATION
		      "Call the error handler to examine the selected process."))))
    (SELECTQ CHOICE
      (PROCESS-ARREST (FUNCALL PROCESS ':ARREST-REASON))
      (PROCESS-UN-ARREST (FUNCALL PROCESS ':REVOKE-ARREST-REASON))
      (PROCESS-FLUSH (FUNCALL PROCESS ':FLUSH))
      (PROCESS-RESET (FUNCALL PROCESS ':RESET))
      (PROCESS-EH (FUNCALL-SELF ':FORCE-KBD-INPUT `(EH ,PROCESS)))
      (NIL)
      (OTHERWISE (BEEP))))))

(DEFINE-PEEK-MODE PEEK-WINDOW-HIERARCHY #/W "Window hierarchy")

(DEFUN PEEK-WINDOW-HIERARCHY (IGNORE)
  (SCROLL-MAINTAIN-LIST #'(LAMBDA () ALL-THE-SCREENS)
			#'(LAMBDA (SCREEN)
			    (LIST ()
			      (SCROLL-PARSE-ITEM (FORMAT NIL "Screen ~A" SCREEN))
			      (PEEK-WINDOW-INFERIORS SCREEN 2)
			      (SCROLL-PARSE-ITEM "")))))

(DEFUN PEEK-WINDOW-INFERIORS (WINDOW INDENT)
  (SCROLL-MAINTAIN-LIST `(LAMBDA () (SHEET-INFERIORS ',WINDOW))
			`(LAMBDA (SHEET)
			   (LIST ()
			     (SCROLL-PARSE-ITEM 
			       ':MOUSE `(NIL :EVAL (PEEK-WINDOW-MENU ',SHEET)
					     :DOCUMENTATION
					     "Menu of useful things to do to this window.")
			       (FORMAT NIL "~VX~A" ,INDENT SHEET))
			     (PEEK-WINDOW-INFERIORS SHEET (+ ,INDENT 4))))))

(DEFUN PEEK-WINDOW-MENU (&REST ARGS)
  (LEXPR-FUNCALL #'PROCESS-RUN-FUNCTION "Peek Window Menu"
		 #'PEEK-WINDOW-MENU-INTERNAL ARGS))

(DEFUN PEEK-WINDOW-MENU-INTERNAL (SHEET &REST IGNORE &AUX CHOICE)
  "Menu for interesting operations on sheets in a peek display"
  (SETQ CHOICE (MENU-CHOOSE
		 '(("Deexpose" :VALUE :DEEXPOSE :DOCUMENTATION "Deexpose the window.")
		   ("Expose" :VALUE :EXPOSE :DOCUMENTATION "Expose the window.")
		   ("Select" :VALUE :SELECT :DOCUMENTATION "Select the window.")
		   ("Deselect" :VALUE :DESELECT :DOCUMENTATION "Deselect the window.")
		   ("Deactivate" :VALUE :DEACTIVATE :DOCUMENTATION "Deactivate the window.")
		   ("Kill" :VALUE :KILL :DOCUMENTATION "Kill the window.")
		   ("Bury" :VALUE :BURY :DOCUMENTATION "Bury the window."))))
  (AND CHOICE (FUNCALL SHEET CHOICE)))

(WINDOW-CREATE 'PEEK ':ACTIVATE-P T)  ;Pre-create one for the system key