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

;;; Inspect structures

(DEFSTRUCT (STACK-FRAME :NAMED)
  STACK-FRAME-SG
  STACK-FRAME-AP
  STACK-FRAME-FUNCTION-NAME)

(DEFSELECT STACK-FRAME
  ((:PRINT :PRINT-SELF) (SF STREAM &REST IGNORE &AUX (AP (STACK-FRAME-AP SF))
						     (RP (SG-REGULAR-PDL (STACK-FRAME-SG SF)))
						     (FUNCTION (RP-FUNCTION-WORD RP AP))
						     (PC (AND (EQ (%DATA-TYPE FUNCTION)
								  DTP-FEF-POINTER)
							      (RP-EXIT-PC RP AP))))
   (LET ((PRINLENGTH 5) (PRINLEVEL 3))
     (FORMAT STREAM "#<Stack-Frame ~A ~[PC=~O~;microcoded~;interpreted~]>"
	     (EH:FUNCTION-NAME FUNCTION)
	     (COND (PC 0)
		   ((EQ (%DATA-TYPE FUNCTION) DTP-U-ENTRY) 1)
		   (T 2))
	     PC))))

(DEFFLAVOR INSPECT-WINDOW ()
	   (BASIC-INSPECT
	    ANY-MOUSE-BUTTONS-TEXT-SCROLL-WINDOW-MIXIN
	    FUNCTION-TEXT-SCROLL-WINDOW MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW
	    FLASHY-SCROLLING-MIXIN DONT-SELECT-WITH-MOUSE-MIXIN BORDERS-MIXIN
	    MARGIN-SCROLL-MIXIN MARGIN-REGION-MIXIN
	    TOP-LABEL-MIXIN
	    ANY-TYI-MIXIN WINDOW)
  (:DEFAULT-INIT-PLIST :MARGIN-SCROLL-REGIONS '((:TOP "Top of object")
						(:BOTTOM "Bottom of object"))
		       :FLASHY-SCROLLING-REGION '((20 0.40s0 0.60s0)
						  (20 0.40s0 0.60s0))
		       :LABEL (LIST NIL NIL NIL NIL FONTS:HL12B "Empty"))
  (:DOCUMENTATION :COMBINATION "Scroll window for the inspector."))

;;; This flavor should be in SCROLL somewhere
(DEFFLAVOR ANY-MOUSE-BUTTONS-TEXT-SCROLL-WINDOW-MIXIN
	((SINGLE-RIGHT-MENU NIL))		;Menu for single-click-right
	()
  (:INCLUDED-FLAVORS MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW)
  :INITABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  :GETTABLE-INSTANCE-VARIABLES)

(DEFMETHOD (ANY-MOUSE-BUTTONS-TEXT-SCROLL-WINDOW-MIXIN :MOUSE-BUTTONS) (BD X Y &AUX ITEM TYPE)
  (MULTIPLE-VALUE (ITEM TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y))
  (COND ((= (SETQ BD (MOUSE-BUTTON-ENCODE BD)) #\MOUSE-3-2)
	 (MOUSE-CALL-SYSTEM-MENU))
	((AND SINGLE-RIGHT-MENU (= BD #\MOUSE-3-1))
	 (PROCESS-RUN-FUNCTION "Menu Choose"
			       #'(LAMBDA (US BD MENU &AUX CHOICE)
				   (SETQ CHOICE (FUNCALL MENU ':CHOOSE))
				   (AND CHOICE
					(FUNCALL US ':FORCE-KBD-INPUT
						 (LIST ':MENU CHOICE US BD))))
			       SELF BD SINGLE-RIGHT-MENU))
	(T
	 (FUNCALL-SELF ':FORCE-KBD-INPUT (LIST TYPE ITEM SELF BD)))))


(DEFFLAVOR BASIC-INSPECT ((CURRENT-OBJECT (NCONS NIL))
			  (CURRENT-DISPLAY NIL)
			  ;; For list structure hacking
			  (DISPLAYING-LIST NIL)
			  (MODIFY-MODE NIL)
			  LIST-BLINKER)
	   ()
  :SETTABLE-INSTANCE-VARIABLES
  (:GETTABLE-INSTANCE-VARIABLES MODIFY-MODE)
  (:INCLUDED-FLAVORS MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW))

(DEFMETHOD (BASIC-INSPECT :AFTER :INIT) (IGNORE)
  (SETQ LIST-BLINKER (DEFINE-BLINKER SELF 'FOLLOW-LIST-STRUCTURE-BLINKER ':VISIBILITY NIL)))

(DEFMACRO INSPECT-DATA-TYPE (TYPE)
  `(MULTIPLE-VALUE (DISPLAY-LIST ARG ALT-PRINT-FUN FIRST-TOP-ITEM OBJ-LABEL)
     (FUNCALL WINDOW
	      ',(INTERN (STRING-APPEND "OBJECT-" TYPE) "")
	      OBJECT)))

(DEFUN INSPECT-SETUP-OBJECT-DISPLAY-LIST (OBJECT WINDOW &OPTIONAL TOP-ITEM LABEL
					   &AUX DISPLAY-LIST ARG STR ALT-PRINT-FUN
					        FIRST-TOP-ITEM OBJ-LABEL)
  (COND ((EQ (TYPEP OBJECT) 'STACK-FRAME) (INSPECT-DATA-TYPE STACK-FRAME))
	((NAMED-STRUCTURE-P OBJECT) (INSPECT-DATA-TYPE NAMED-STRUCTURE))
	(T
	 (SELECTQ (DATA-TYPE OBJECT)
	   (DTP-INSTANCE (INSPECT-DATA-TYPE INSTANCE))
	   (DTP-ARRAY-POINTER (INSPECT-DATA-TYPE ARRAY))
	   (DTP-LIST (INSPECT-DATA-TYPE LIST))
	   (DTP-SYMBOL (INSPECT-DATA-TYPE SYMBOL))
	   (DTP-SELECT-METHOD (INSPECT-DATA-TYPE SELECT-METHOD))
	   ((DTP-CLOSURE DTP-ENTITY) (INSPECT-DATA-TYPE CLOSURE))
	   (DTP-FEF-POINTER (INSPECT-DATA-TYPE FEF)))))
  (LIST OBJECT
	(OR ALT-PRINT-FUN 'INSPECT-PRINTER)
	ARG DISPLAY-LIST (OR TOP-ITEM FIRST-TOP-ITEM 0)
	(OR LABEL
	    OBJ-LABEL
	    (LIST NIL NIL NIL NIL (LABEL-FONT (FUNCALL WINDOW ':LABEL))
		  (IF (LISTP OBJECT)
		      "a list"
		      (NSUBSTRING (SETQ STR (FORMAT NIL "~S~%" OBJECT))
				  0 (STRING-SEARCH-CHAR #\CR STR)))))))

(DEFUN INSPECT-SETUP-OBJECT (OBJECT WINDOW &OPTIONAL TOP-ITEM)
  (LET ((DISP (INSPECT-SETUP-OBJECT-DISPLAY-LIST OBJECT WINDOW TOP-ITEM)))
    (FUNCALL WINDOW ':SETUP (CDR DISP))
    (FUNCALL WINDOW ':SET-CURRENT-OBJECT (CAR DISP))
    DISP))

(DEFMETHOD (BASIC-INSPECT :SETUP-OBJECT) (SL)
  (FUNCALL-SELF ':SETUP (CDR SL))
  (FUNCALL-SELF ':SET-CURRENT-OBJECT (CAR SL))
  SL)

(DEFUN INSPECT-PRINTER (LINE ARG STREAM ITEM-NO)
  (DOLIST (ELT LINE)
    (COND ((NUMBERP ELT)
	   (FORMAT STREAM "~VT" ELT))
	  ((STRINGP ELT)
	   (PRINC ELT STREAM))
	  ((NLISTP ELT)
	   (FERROR NIL "Unknown element type: ~S" ELT))
	  ((STRINGP (CAR ELT))
	   (LEXPR-FUNCALL #'FORMAT STREAM ELT))
	  (T
	   (SELECTQ (FIRST ELT)
	     (:FUNCTION (LEXPR-FUNCALL (SECOND ELT) ARG STREAM ITEM-NO (CDDR ELT)))
	     (:COLON (FORMAT STREAM ":~VT " (SECOND ELT)))
	     (:ITEM (FUNCALL STREAM ':ITEM ELT (SECOND ELT)
			     #'(LAMBDA (ELT &REST ARGS)
				 (LEXPR-FUNCALL (OR (FOURTH ELT)
						    #'PRINT-ITEM-CONCISELY)
						(THIRD ELT) ARGS))))
	     (OTHERWISE (FERROR NIL "Unknown item type ~A" (FIRST ELT))))))))

;;; Inspection of each type of object is done by a message, so that some of them
;;; may be redefined for some unspecified application
(DEFMETHOD (BASIC-INSPECT :OBJECT-NAMED-STRUCTURE) (OBJ &AUX (MAXL -1) ITEMS RESULT NSS)
  (SETQ NSS (NAMED-STRUCTURE-SYMBOL OBJ))
  (PUSH `("Named structure of type "
	  (:ITEM NAMED-STRUCTURE-SYMBOL ,NSS))
	RESULT)
  (PUSH '("") RESULT)
  (DOLIST (ELT (SETQ ITEMS (GET NSS 'SI:DEFSTRUCT-ITEMS)))
    (SETQ MAXL (MAX (FLATSIZE ELT) MAXL)))
  (SETQ MAXL (1+ MAXL))
  ;; For a named structure, each line contains the name and the value
  (DOLIST (ELT ITEMS)
    (PUSH `((:ITEM NAMED-STRUCTURE-SLOT ,ELT)
	    (:COLON ,MAXL)
	    (:ITEM NAMED-STRUCTURE-VALUE ,(CAR (ERRSET (FUNCALL ELT OBJ) NIL))))
	  RESULT))
  (NREVERSE RESULT))

(DEFUN (NAMED-STRUCTURE-SLOT SET-FUNCTION) (ITEM NEW-VALUE OBJECT)
  (EVAL `(SETF (,(THIRD (SECOND ITEM)) ',OBJECT) ',NEW-VALUE)))

(DEFPROP NAMED-STRUCTURE-SLOT T ONLY-WHEN-MODIFY)


(DEFMETHOD (BASIC-INSPECT :OBJECT-INSTANCE) (OBJ &AUX (MAXL -1) RESULT)
  (SETQ RESULT (LIST '("")
		     `("An object of flavor "
		       (:ITEM FLAVOR ,(TYPEP OBJ))
		       ".  Function is "
		       (:ITEM FLAVOR-FUNCTION
			      ,(%P-CONTENTS-OFFSET (%P-CONTENTS-AS-LOCATIVE-OFFSET OBJ 0)
						   %INSTANCE-DESCRIPTOR-FUNCTION)))))
  (DO ((BINDINGS (%P-CONTENTS-OFFSET (%P-CONTENTS-AS-LOCATIVE-OFFSET OBJ 0)
				     %INSTANCE-DESCRIPTOR-BINDINGS)
		 (CDR BINDINGS))
       (I 1 (1+ I)))
      ((NULL BINDINGS))
    (SETQ MAXL (MAX (FLATSIZE (%FIND-STRUCTURE-HEADER (CAR BINDINGS))) MAXL)))
  (SETQ MAXL (1+ MAXL))
  (DO ((BINDINGS (%P-CONTENTS-OFFSET (%P-CONTENTS-AS-LOCATIVE-OFFSET OBJ 0)
				     %INSTANCE-DESCRIPTOR-BINDINGS)
		 (CDR BINDINGS))
       (SYM)
       (I 1 (1+ I)))
      ((NULL BINDINGS))
    (SETQ SYM (%FIND-STRUCTURE-HEADER (CAR BINDINGS)))
    (PUSH `((:ITEM INSTANCE-SLOT ,SYM)
	    (:COLON ,MAXL)
	    ,(IF (= (%P-LDB-OFFSET %%Q-DATA-TYPE OBJ I) DTP-NULL)
		 "unbound"
		 `(:ITEM INSTANCE-VALUE ,(%P-CONTENTS-OFFSET OBJ I))))
	  RESULT))
  (NREVERSE RESULT))

(DEFUN (INSTANCE-SLOT SET-FUNCTION) (ITEM NEW-VALUE OBJECT)
  (LET* ((SLOT (THIRD (SECOND ITEM)))
	 (MESSAGE-NAME (INTERN (STRING-APPEND "SET-" SLOT) "")))
    (IF (GET-HANDLER-FOR MESSAGE-NAME OBJECT)
	(ERRSET (FUNCALL OBJECT MESSAGE-NAME NEW-VALUE) T)
	(SET-IN-INSTANCE OBJECT SLOT NEW-VALUE))))

(DEFPROP INSTANCE-SLOT T ONLY-WHEN-MODIFY)


(DEFMETHOD (BASIC-INSPECT :OBJECT-CLOSURE) (OBJ &AUX RESULT (C (%MAKE-POINTER DTP-LIST OBJ)))
  (SETQ RESULT `("Function is "
		 (:ITEM CLOSURE-FUNCTION ,(INSPECT-FUNCTION-FROM (CAR C)))))
  (COND ((ENTITYP OBJ)
	 (PUSH '(".  ") RESULT)
	 (PUSH `(:ITEM TYPE ,(TYPEP OBJ)) RESULT)
	 (PUSH '("An object of type ") RESULT)))
  (SETQ RESULT (LIST '("") RESULT))
  (LET ((SYM NIL)
	(MAXL -1))
    (DO L (CDR C) (CDDR L) (NULL L)
	(SETQ SYM (%FIND-STRUCTURE-HEADER (CAR L)))
	(SETQ MAXL (MAX (FLATSIZE SYM) MAXL)))
    (SETQ MAXL (1+ MAXL))
    (DO L (CDR C) (CDDR L) (NULL L)
	(SETQ SYM (%FIND-STRUCTURE-HEADER (CAR L)))
	(PUSH `((:ITEM CLOSURE-SLOT ,SYM)
		(:COLON ,MAXL)
		,(IF (= (%P-DATA-TYPE (CADR L)) DTP-NULL)
		     "unbound"
		     `(:ITEM CLOSURE-VALUE ,(CAADR L))))
	      RESULT))
    (NREVERSE RESULT)))

(DEFUN INSPECT-FUNCTION-FROM (FROM)
  (DO () (())
    (COND ((SYMBOLP FROM)
	   (AND (NOT (FBOUNDP FROM))
		(RETURN FROM))
	   (SETQ FROM (FSYMEVAL FROM)))
	  (T (RETURN FROM)))))

(DEFUN (CLOSURE-SLOT SET-FUNCTION) (ITEM NEW-VALUE OBJECT)
  (LET* ((SLOT (THIRD (SECOND ITEM)))
	 (MESSAGE-NAME (INTERN (STRING-APPEND "SET-" SLOT) "")))
    (IF (GET-HANDLER-FOR MESSAGE-NAME OBJECT)
	(ERRSET (FUNCALL OBJECT MESSAGE-NAME NEW-VALUE) T)
	(SET-IN-CLOSURE OBJECT SLOT NEW-VALUE))))

(DEFPROP CLOSURE-SLOT T ONLY-WHEN-MODIFY)


(DEFMETHOD (BASIC-INSPECT :OBJECT-SELECT-METHOD) (SM &AUX (RESULT NIL))
  (SETQ SM (%MAKE-POINTER DTP-LIST SM))
  (DO ((S SM (CDR S))
       (MAXL -1))
      ((SYMBOLP S)
       (SETQ RESULT (SORT RESULT #'(LAMBDA (Y X)
				     (ALPHALESSP (THIRD (FIRST X)) (THIRD (FIRST Y))))))
       (SETQ MAXL (1+ (MAX MAXL (STRING-LENGTH "Tail pointer"))))
       (DOLIST (R RESULT)
	 (SETF (SECOND (SECOND R)) MAXL))
       (PUSH `((:ITEM SELECT-METHOD-TAIL-POINTER "Tail pointer" PRINC)
	       (:COLON ,MAXL)
	       (:ITEM SELECT-METHOD-TAIL-FUNCTION ,(AND S (INSPECT-FUNCTION-FROM S))))
	     RESULT)
       (NREVERSE RESULT))
    (DO ((KWDS (CAAR S) (CDR KWDS))
	 (K))
	((NULL KWDS))
      (IF (LISTP KWDS)
	  (SETQ K (CAR KWDS))
	  (SETQ K KWDS)
	  (SETQ KWDS NIL))		
      (PUSH `((:ITEM SELECT-METHOD-KEYWORD ,K)
	      ,(LIST ':COLON 0)
	      (:ITEM SELECT-METHOD-FUNCTION ,(CDAR S)))
	      RESULT)
      (SETQ MAXL (MAX MAXL (FLATSIZE K))))))

(DEFUN (SELECT-METHOD-TAIL-POINTER SET-FUNCTION) (IGNORE NEW-VALUE SM)
  (RPLACD (LAST (%MAKE-POINTER DTP-LIST SM)) NEW-VALUE))

(DEFPROP SELECT-METHOD-TAIL-POINTER T ONLY-WHEN-MODIFY)

(DEFUN (SELECT-METHOD-KEYWORD SET-FUNCTION) (ITEM NEW-VALUE SM)
  (SETQ SM (%MAKE-POINTER DTP-LIST SM)
	ITEM (THIRD (SECOND ITEM)))
  (DO ((S SM (CDR S)))
      ((SYMBOLP S))
    (COND ((IF (SYMBOLP (CAAR S))
	       (EQ (CAAR S) ITEM)
	       (MEMQ ITEM (CAAR S)))
	   (SETF (CDAR S) NEW-VALUE)
	   (RETURN)))))

(DEFPROP SELECT-METHOD-KEYWORD T ONLY-WHEN-MODIFY)


(DEFMETHOD (BASIC-INSPECT :OBJECT-SYMBOL) (OBJ)
  `(((:ITEM SYMBOL-VALUE-CELL "Value is " PRINC)
     ,(IF (BOUNDP OBJ)
	  `(:ITEM SYMBOL-VALUE ,(SYMEVAL OBJ))
	  "unbound"))
    ((:ITEM SYMBOL-FUNCTION-CELL "Function is " PRINC)
     ,(IF (FBOUNDP OBJ)
	  `(:ITEM SYMBOL-FUNCTION ,(FSYMEVAL OBJ))
	  "unbound"))
    ((:ITEM SYMBOL-PROPERTY-CELL "Property list: " PRINC)
     (:ITEM SYMBOL-PROPERTY-LIST ,(PLIST OBJ)))
    ("Package: "
     (:ITEM SYMBOL-PACKAGE ,(CAR (PACKAGE-CELL-LOCATION OBJ))))))

(DEFUN (SYMBOL-VALUE-CELL SET-FUNCTION) (IGNORE NEW-VALUE OBJECT)
  (SET OBJECT NEW-VALUE))

(DEFPROP SYMBOL-VALUE-CELL T ONLY-WHEN-MODIFY)

(DEFUN (SYMBOL-FUNCTION-CELL SET-FUNCTION) (IGNORE NEW-VALUE OBJECT)
  (FSET OBJECT NEW-VALUE))

(DEFPROP SYMBOL-FUNCTION-CELL T ONLY-WHEN-MODIFY)

(DEFUN (SYMBOL-PROPERTY-CELL SET-FUNCTION) (IGNORE NEW-VALUE OBJECT)
  (SETPLIST OBJECT NEW-VALUE))

(DEFPROP SYMBOL-PROPERTY-CELL T ONLY-WHEN-MODIFY)


(DEFMETHOD (BASIC-INSPECT :OBJECT-FEF) (FEF)
  (FEF-DISPLAY-LIST FEF SELF))

(DEFMETHOD (BASIC-INSPECT :OBJECT-STACK-FRAME) (SF)
  (LET* ((RP (SG-REGULAR-PDL (STACK-FRAME-SG SF)))
	 (AP (STACK-FRAME-AP SF))
	 (FUNCTION (RP-FUNCTION-WORD RP AP)))
    (COND ((LISTP FUNCTION)
	   (FUNCALL-SELF ':OBJECT-LIST FUNCTION))
	  (T
	   (FEF-DISPLAY-LIST FUNCTION SELF (RP-EXIT-PC RP AP)
			     (STACK-FRAME-FUNCTION-NAME SF))))))

(DEFUN FEF-DISPLAY-LIST (FEF WINDOW &OPTIONAL PC-NOW LABEL &AUX LIST PC-IDX)
  (DO ((I 0 (1+ I))
       (PC (FEF-INITIAL-PC FEF) (+ PC (COMPILER:DISASSEMBLE-INSTRUCTION-LENGTH FEF PC)))
       (LIM-PC (COMPILER:DISASSEMBLE-LIM-PC FEF)))
      (( PC LIM-PC)
       (COND ((EQ PC PC-NOW)			;PC off the end
	      (SETQ PC-IDX I)
	      (PUSH T LIST))))
    (AND (EQ PC PC-NOW) (SETQ PC-IDX I))
    (PUSH PC LIST))
  (PROG () (RETURN (NREVERSE LIST) (LIST FEF PC-IDX) 'PRINT-FEF-INSTRUCTION
		   (AND PC-NOW
			(MAX 0 (- PC-IDX (// (* 3 (// (SHEET-INSIDE-HEIGHT WINDOW)
						      (SHEET-LINE-HEIGHT WINDOW)))
					     4))))
		   LABEL)))

(DEFUN PRINT-FEF-INSTRUCTION (PC FEF-AND-PC-IDX STANDARD-OUTPUT ITEM-NO
			      &AUX (FEF (FIRST FEF-AND-PC-IDX))
				   (PC-IDX (SECOND FEF-AND-PC-IDX)))
  (FUNCALL STANDARD-OUTPUT ':STRING-OUT (IF (EQ ITEM-NO PC-IDX) "=> " "   "))
  (LET ((COMPILER:DISASSEMBLE-OBJECT-OUTPUT-FUN
	 #'(LAMBDA (OBJ PREFIX &REST IGNORE)
	     (FUNCALL STANDARD-OUTPUT ':STRING-OUT PREFIX)
	     (FUNCALL STANDARD-OUTPUT ':ITEM OBJ ':VALUE #'TV:PRINT-ITEM-CONCISELY))))
    (AND (NUMBERP PC) (COMPILER:DISASSEMBLE-INSTRUCTION FEF PC))))

;;; List structure hacking

(DEFFLAVOR FOLLOW-LIST-STRUCTURE-BLINKER
	((LIST-ITEM NIL))
	(BLINKER)
  (:INITABLE-INSTANCE-VARIABLES LIST-ITEM))

(DEFMETHOD (FOLLOW-LIST-STRUCTURE-BLINKER :SET-LIST-ITEM) (NEW-LIST-ITEM)
  (AND (NEQ LIST-ITEM NEW-LIST-ITEM)
       (WITHOUT-INTERRUPTS
	 (OPEN-BLINKER SELF)
	 (SETQ LIST-ITEM NEW-LIST-ITEM))))

(DEFMETHOD (FOLLOW-LIST-STRUCTURE-BLINKER :BLINK) (&AUX Y LAST-LEFT-X LAST-RIGHT-X
							ITEM END-ITEM
							START-XPOS END-XPOS MAX-X)
  (SETQ MAX-X (SHEET-INSIDE-RIGHT SHEET))
  (MULTIPLE-VALUE-BIND (ITEM-ARRAY TOP-ITEM BOTTOM-ITEM CHARW LINEH IL IT)
      (FUNCALL SHEET ':LIST-BLINKER-INFO)
    (SETQ ITEM (THIRD LIST-ITEM)
	  START-XPOS (1- (SECOND LIST-ITEM))
	  END-ITEM (FIFTH LIST-ITEM)
	  END-XPOS (1+ (FOURTH LIST-ITEM)))
    (SETQ Y (+ (* LINEH (- ITEM TOP-ITEM)) IT -2)
	  LAST-LEFT-X (1- IL))
    (COND ((AND ( ITEM TOP-ITEM)
		(< ITEM BOTTOM-ITEM))
	   ;; Top is on screen, draw the top line
	   (%DRAW-LINE (SETQ LAST-LEFT-X START-XPOS) Y
		       (SETQ LAST-RIGHT-X
			     (MIN MAX-X
				  (IF ( ITEM END-ITEM)
				      (+ IL 1 (* CHARW
						 (STRING-LENGTH
						   (SECOND (AREF ITEM-ARRAY ITEM)))))
				      END-XPOS)))
		       Y
		       ALU-XOR T SHEET)))
    (DO () (( ITEM BOTTOM-ITEM))
      (COND (( ITEM TOP-ITEM)
	     ;; Item is on screen, so there are side bars
	     (%DRAW-LINE LAST-LEFT-X (1+ Y)
			 LAST-LEFT-X (+ Y (1- LINEH))
			 ALU-XOR T SHEET)
	     (%DRAW-LINE LAST-RIGHT-X (1+ Y)
			 LAST-RIGHT-X (+ Y (1- LINEH))
			 ALU-XOR T SHEET)))
      (SETQ Y (+ Y LINEH))
      ;; If we just handled the side-bars for the last item, return
      (AND (OR (= ITEM END-ITEM) ( ITEM (1- BOTTOM-ITEM)))
	   (RETURN))
      ;; Onto the next item, and take care of the short horizontal bars on the right and left
      (COND ((> (SETQ ITEM (1+ ITEM)) TOP-ITEM)
	     (%DRAW-LINE LAST-LEFT-X Y
			 (SETQ LAST-LEFT-X (1- IL)) Y
			 ALU-XOR T SHEET)
	     (%DRAW-LINE LAST-RIGHT-X Y
			 (SETQ LAST-RIGHT-X
			       (MIN MAX-X
				    (IF ( ITEM END-ITEM)
					(+ IL 1 (* CHARW
						   (STRING-LENGTH
						     (SECOND (AREF ITEM-ARRAY ITEM)))))
					END-XPOS)))
			 Y
			 ALU-XOR T SHEET))
	    ((= ITEM TOP-ITEM)
	     (SETQ LAST-RIGHT-X
		   (MIN MAX-X
			(IF ( ITEM END-ITEM)
			    (+ IL 1 (* CHARW (STRING-LENGTH (SECOND (AREF ITEM-ARRAY ITEM)))))
			    END-XPOS))))))
    (AND (= ITEM END-ITEM)
	 ;; If didn't run off bottom of screen, draw in bottom line
	 (%DRAW-LINE LAST-LEFT-X Y
		     LAST-RIGHT-X Y
		     ALU-XOR T SHEET))))

(DEFMETHOD (FOLLOW-LIST-STRUCTURE-BLINKER :SIZE) ()
  (PROG () (RETURN (SHEET-INSIDE-WIDTH SHEET) (SHEET-INSIDE-HEIGHT SHEET))))


(DEFMETHOD (BASIC-INSPECT :LIST-BLINKER-INFO) ()
  (PROG ()
    (RETURN ITEMS
	    TOP-ITEM (+ TOP-ITEM (SHEET-NUMBER-OF-INSIDE-LINES))
	    CHAR-WIDTH LINE-HEIGHT
	    (SHEET-INSIDE-LEFT) (SHEET-INSIDE-TOP))))

(DEFMETHOD (BASIC-INSPECT :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (AND DISPLAYING-LIST
       ;; If displaying a list, then must regrind when size changes
       (INSPECT-SETUP-OBJECT CURRENT-OBJECT SELF TOP-ITEM)))

(DEFMETHOD (BASIC-INSPECT :MOUSE-MOVES) (X Y &AUX ITEM TYPE LEFT TOP BWIDTH BHEIGHT)
  (MOUSE-SET-BLINKER-CURSORPOS)
  (MULTIPLE-VALUE (ITEM TYPE LEFT BWIDTH TOP)
    (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y))
  (COND ((MEMQ TYPE '(:LIST-STRUCTURE :LIST-STRUCTURE-TOP-LEVEL))
	 (BLINKER-SET-VISIBILITY ITEM-BLINKER NIL)
	 ;; LEFT, BWIDTH, TOP are invalid
	 (FUNCALL LIST-BLINKER ':SET-LIST-ITEM ITEM)
	 (BLINKER-SET-VISIBILITY LIST-BLINKER T))
	(TYPE
	 (BLINKER-SET-VISIBILITY LIST-BLINKER NIL)
	 (SETQ BWIDTH (- BWIDTH LEFT)
	       BHEIGHT (FONT-BLINKER-HEIGHT CURRENT-FONT))
	 (BLINKER-SET-CURSORPOS ITEM-BLINKER (- LEFT (SHEET-INSIDE-LEFT))
				(- TOP (SHEET-INSIDE-TOP)))
	 (BLINKER-SET-SIZE ITEM-BLINKER BWIDTH BHEIGHT)
	 (BLINKER-SET-VISIBILITY ITEM-BLINKER T))
	(T (BLINKER-SET-VISIBILITY LIST-BLINKER NIL)
	   (BLINKER-SET-VISIBILITY ITEM-BLINKER NIL))))

(DEFMETHOD (BASIC-INSPECT :MOUSE-SENSITIVE-ITEM) (X Y)
  (PROG FOUND-ITEM (LILN)
	(MULTIPLE-VALUE-BIND (ITEM TYPE LEFT BWIDTH TOP)
	    (MOUSE-SENSITIVE-ITEM X Y)
	  (AND (IF MODIFY-MODE
		   (NULL (GET TYPE 'SET-FUNCTION))
		   (GET TYPE 'ONLY-WHEN-MODIFY))
	       ;; Only accept changeable items in modify mode
	       (SETQ ITEM NIL))
	  (COND (ITEM (RETURN-FROM FOUND-ITEM ITEM TYPE LEFT BWIDTH TOP))
		((NOT DISPLAYING-LIST))
		((AND ( Y (SHEET-INSIDE-TOP))
		      (< Y (SHEET-INSIDE-BOTTOM)))
		 ;; No explicit item on this line -- find list structure if it exists
		 (LET ((LINE-NO (+ TOP-ITEM (SHEET-LINE-NO NIL Y))))
		   ;; Starting from this line, work backwards until an enclosing
		   ;; piece of structure is found
		   (OR ( LINE-NO (ARRAY-ACTIVE-LENGTH ITEMS))
		       (DOLIST (LI (FIRST (AREF ITEMS LINE-NO)))
			 (AND (COND ((= LINE-NO (SETQ LILN (THIRD LI)))
				     ;; Entry starts on this line -- within range on right?
				     ( X (SECOND LI)))
				    ((> LINE-NO LILN)
				     ;; Entry starts on some previous line -- so we are ok
				     T))
			      (COND ((= LINE-NO (SETQ LILN (FIFTH LI)))
				     ;; Entry ends on this line, within range on left?
				     (< X (FOURTH LI)))
				    ((< LINE-NO LILN)
				     ;; Entry starts before -- so this is good
				     T))
			      (IF (AND MODIFY-MODE (EQ (FIRST LI) ':TOP-LEVEL))
				  (RETURN-FROM FOUND-ITEM NIL)
				  (RETURN-FROM FOUND-ITEM LI
					       (IF (EQ (FIRST LI) ':TOP-LEVEL)
						   ':LIST-STRUCTURE-TOP-LEVEL
						   ':LIST-STRUCTURE))))))))))))

(DEFMETHOD (BASIC-INSPECT :OBJECT-LIST) (LIST)
  (MULTIPLE-VALUE-BIND (STRING-LIST ATOMIC-ITEMS LIST-ITEMS)
      (GRIND-INTO-LIST LIST (// (SHEET-INSIDE-WIDTH) CHAR-WIDTH) T)
    (DO ((L STRING-LIST (CDR L))
	 (AIS ATOMIC-ITEMS (CDR AIS)))
	((NULL L))
      (DOLIST (I (CAR AIS))
	(SETF (THIRD I) (+ (SHEET-INSIDE-LEFT) (* (THIRD I) CHAR-WIDTH)))
	(SETF (FOURTH I) (+ (SHEET-INSIDE-LEFT) (* (FOURTH I) CHAR-WIDTH))))
      (RPLACA L (LIST NIL (CAR L) (CAR AIS))))
    (DOLIST (I LIST-ITEMS)
      (SETF (SECOND I) (+ (SHEET-INSIDE-LEFT) (* (SECOND I) CHAR-WIDTH)))
      (SETF (FOURTH I) (+ (SHEET-INSIDE-LEFT) (* (FOURTH I) CHAR-WIDTH))))
    (SETQ LIST-ITEMS (SORT LIST-ITEMS
			   #'(LAMBDA (X Y)
			       (COND ((< (THIRD Y) (THIRD X)) T)
				     ((> (THIRD Y) (THIRD X)) NIL)
				     (T (> (SECOND X) (SECOND Y)))))))
    (DO ((LINE (1- (LENGTH STRING-LIST)) (1- LINE))
	 (CURRENT LIST-ITEMS))
	((< LINE 0))
      (DO ()
	  ((OR (NULL CURRENT)
	       ( (THIRD (CAR CURRENT)) LINE)))
	(SETQ CURRENT (CDR CURRENT)))
      (RPLACA (CAR (NTHCDR LINE STRING-LIST)) CURRENT))
    (PROG () (RETURN STRING-LIST ':LIST-STRUCTURE 'INSPECT-LIST-PRINTER))))

(DEFMETHOD (BASIC-INSPECT :BEFORE :SETUP) (SL)
  (SETQ CURRENT-DISPLAY SL
	DISPLAYING-LIST NIL)
  (BLINKER-SET-VISIBILITY LIST-BLINKER NIL))

(DEFMETHOD (BASIC-INSPECT :AFTER :SETUP) (NEW-SETUP)
  (SETQ DISPLAYING-LIST (EQ (SECOND NEW-SETUP) ':LIST-STRUCTURE)))

(DEFMETHOD (BASIC-INSPECT :AFTER :HANDLE-MOUSE) (&REST IGNORE)
  (BLINKER-SET-VISIBILITY LIST-BLINKER NIL))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-INSPECT)
(DEFUN INSPECT-LIST-PRINTER (ITEM IGNORE STREAM ITEM-NO)
  (FUNCALL STREAM ':STRING-OUT (SECOND ITEM))
  (ASET (THIRD ITEM) DISPLAYED-ITEMS (- ITEM-NO TOP-ITEM))))

(DEFUN (:LIST-STRUCTURE SET-FUNCTION) (ITEM NEW-VALUE IGNORE)
  (RPLACA (FIRST (SECOND ITEM)) NEW-VALUE))

(DEFUN (LOCATIVE SET-FUNCTION) (ITEM NEW-VALUE IGNORE)
  (RPLACD (SECOND ITEM) NEW-VALUE))

;;; Array hacking
(DEFMETHOD (BASIC-INSPECT :OBJECT-ARRAY) (OBJ &AUX (LEADER NIL) (ARRAY NIL))
  (AND (ARRAY-HAS-LEADER-P OBJ)
       (DOTIMES (I (ARRAY-DIMENSION-N 0 OBJ))
	 (PUSH (- -1 I) LEADER)))
  (COND ((STRINGP OBJ)
	 (SETQ ARRAY `((,OBJ))))
	((> (ARRAY-/#-DIMS OBJ) 1)
	 (SETQ ARRAY `((,(FORMAT NIL "~S" OBJ)))))
	(T
	 (DOTIMES (I (ARRAY-DIMENSION-N 1 OBJ))
	   (PUSH I ARRAY))
	 (SETQ ARRAY (NREVERSE ARRAY))))
  (PROG () (RETURN (NCONC (NREVERSE LEADER) ARRAY) OBJ 'INSPECT-ARRAY-PRINTER)))

(DEFUN INSPECT-ARRAY-PRINTER (ITEM OBJ STREAM ARG3)
  (COND ((NOT (NUMBERP ITEM))
	 (INSPECT-PRINTER ITEM OBJ STREAM ARG3))
	((< ITEM 0)
	 (SETQ ITEM (- -1 ITEM))
	 (FUNCALL STREAM ':ITEM ITEM 'LEADER-SLOT
		  #'(LAMBDA (ITEM STREAM)
		      (FORMAT STREAM "Leader ~D" ITEM)))
	 (FORMAT STREAM ":~12T ")
	 (FUNCALL STREAM ':ITEM (ARRAY-LEADER OBJ ITEM) ':VALUE #'PRINT-ITEM-CONCISELY))
	(T
	 (FUNCALL STREAM ':ITEM ITEM '1D-ARRAY-SLOT
		  #'(LAMBDA (ITEM STREAM)
		      (FORMAT STREAM "Elt ~D" ITEM)))
	 (FORMAT STREAM ":~9T ")
	 (FUNCALL STREAM ':ITEM (AREF OBJ ITEM) ':VALUE #'PRINT-ITEM-CONCISELY))))

(DEFUN (LEADER-SLOT SET-FUNCTION) (ITEM NEW-VALUE OBJECT)
  (STORE-ARRAY-LEADER NEW-VALUE OBJECT (SECOND ITEM)))

(DEFPROP LEADER-SLOT T ONLY-WHEN-MODIFY)

(DEFUN (1D-ARRAY-SLOT SET-FUNCTION) (ITEM NEW-VALUE OBJECT)
  (ASET NEW-VALUE OBJECT (SECOND ITEM)))

(DEFPROP 1D-ARRAY-SLOT T ONLY-WHEN-MODIFY)

;;; Other windows needed for the inspector
(DEFFLAVOR INSPECT-HISTORY-WINDOW ((CACHE NIL))
	   (LINE-AREA-TEXT-SCROLL-WINDOW
	    ANY-MOUSE-BUTTONS-TEXT-SCROLL-WINDOW-MIXIN
	    FUNCTION-TEXT-SCROLL-WINDOW
	    BASIC-SCROLL-BAR MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW
	    FLASHY-SCROLLING-MIXIN DONT-SELECT-WITH-MOUSE-MIXIN BORDERS-MIXIN
	    MARGIN-REGION-MIXIN
	    ANY-TYI-MIXIN WINDOW)
  :SETTABLE-INSTANCE-VARIABLES
  :GETTABLE-INSTANCE-VARIABLES
  (:DEFAULT-INIT-PLIST :LABEL NIL
    		       :FLASHY-SCROLLING-REGION '((20 0.40s0 0.60s0)
						  (20 0.40s0 0.60s0))
		       :SCROLL-BAR-ALWAYS-DISPLAYED T)
  (:DOCUMENTATION :COMBINATION
		  "History window for the inspector, but no margin scroll region"))

(DEFFLAVOR INSPECT-HISTORY-WINDOW-WITH-MARGIN-SCROLLING
	()
	(MARGIN-SCROLL-MIXIN INSPECT-HISTORY-WINDOW)
  (:DEFAULT-INIT-PLIST :MARGIN-SCROLL-REGIONS '((:TOP "Top of History")
						(:BOTTOM "Bottom of History")))
  (:DOCUMENTATION :COMBINATION "History window for the inspector."))

(DEFMETHOD (INSPECT-HISTORY-WINDOW :INSPECT-OBJECT) (OBJECT INSPECTOR
						     &OPTIONAL TOP-ITEM-NO LABEL
						               DONT-PROPOGATE)
  ;; First, remember current TOP-ITEM of inspector
  (LET ((DISP (FUNCALL INSPECTOR ':CURRENT-DISPLAY)))
    (AND DISP
	 (SETF (FOURTH DISP) (FUNCALL INSPECTOR ':TOP-ITEM)))
    (OR (DOTIMES (I (ARRAY-ACTIVE-LENGTH ITEMS))
	  (COND ((NEQ OBJECT (AREF ITEMS I)))
		(DONT-PROPOGATE (RETURN T))
		(T (FUNCALL-SELF ':DELETE-ITEM I)
		   (RETURN NIL))))
	(FUNCALL-SELF ':APPEND-ITEM OBJECT))
    (FUNCALL-SELF ':PUT-ITEM-IN-WINDOW OBJECT)
    (LET ((CE (ASSQ OBJECT CACHE)))
      (OR CE
	  (PUSH (SETQ CE
		      (INSPECT-SETUP-OBJECT-DISPLAY-LIST OBJECT INSPECTOR TOP-ITEM-NO LABEL))
		CACHE))
      (OR (EQ (CDR CE) DISP)
	  (FUNCALL INSPECTOR ':SETUP-OBJECT CE)))))

(DEFMETHOD (INSPECT-HISTORY-WINDOW :FLUSH-OBJECT) (OBJ)
  (FUNCALL-SELF ':FLUSH-OBJECT-FROM-CACHE OBJ)
  (DOTIMES (I (ARRAY-ACTIVE-LENGTH ITEMS))
    (AND (EQ OBJ (AREF ITEMS I))
	 (RETURN (FUNCALL-SELF ':DELETE-ITEM I)))))

(DEFMETHOD (INSPECT-HISTORY-WINDOW :AFTER :INIT) (IGNORE)
  (SETQ PRINT-FUNCTION #'(LAMBDA (LINE IGNORE STREAM IGNORE)
			   (FUNCALL STREAM ':ITEM LINE ':VALUE #'PRINT-ITEM-CONCISELY))
	PRINT-FUNCTION-ARG NIL))

(DEFMETHOD (INSPECT-HISTORY-WINDOW :FLUSH-OBJECT-FROM-CACHE) (OBJECT)
  (SETQ CACHE (DELQ (ASSQ OBJECT CACHE) CACHE)))

(DEFMETHOD (INSPECT-HISTORY-WINDOW :FLUSH-CONTENTS) ()
  (SETQ CACHE NIL
	TOP-ITEM 0)
  (STORE-ARRAY-LEADER 0 ITEMS 0)
  (FILLARRAY DISPLAYED-ITEMS '(NIL))
  (TV:SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
    (FUNCALL-SELF ':CLEAR-SCREEN)))

(DEFFLAVOR INSPECT-HISTORY-PANE () (PANE-NO-MOUSE-SELECT-MIXIN INSPECT-HISTORY-WINDOW))

(DEFFLAVOR INSPECT-HISTORY-PANE-WITH-MARGIN-SCROLLING
	()
	(PANE-NO-MOUSE-SELECT-MIXIN INSPECT-HISTORY-WINDOW-WITH-MARGIN-SCROLLING))

(DEFFLAVOR INSPECT-PANE () (PANE-NO-MOUSE-SELECT-MIXIN INSPECT-WINDOW))

(DEFFLAVOR INSPECT-TYPEOUT-WINDOW () (ANY-TYI-MIXIN TYPEOUT-WINDOW))

(DEFFLAVOR INSPECT-WINDOW-WITH-TYPEOUT () (TEXT-SCROLL-WINDOW-TYPEOUT-MIXIN INSPECT-WINDOW)
  (:DEFAULT-INIT-PLIST :TYPEOUT-WINDOW '(INSPECT-TYPEOUT-WINDOW
					 :DEEXPOSED-TYPEOUT-ACTION (:EXPOSE-FOR-TYPEOUT))))

(DEFWRAPPER (INSPECT-WINDOW-WITH-TYPEOUT :MOUSE-SENSITIVE-ITEM) (IGNORE . BODY)
  `(COND ((NOT (SHEET-EXPOSED-P TYPEOUT-WINDOW))
	  . ,BODY)))

(DEFFLAVOR INSPECT-PANE-WITH-TYPEOUT () (PANE-NO-MOUSE-SELECT-MIXIN
					 INSPECT-WINDOW-WITH-TYPEOUT))


(DEFFLAVOR INTERACTION-PANE () (PANE-NO-MOUSE-SELECT-MIXIN
				PREEMPTABLE-READ-ANY-TYI-MIXIN NOTIFICATION-MIXIN
				WINDOW))

(DEFMETHOD (INTERACTION-PANE :AFTER :SELECT) (&REST IGNORE)
  (LET ((TW (FUNCALL SUPERIOR ':TYPEOUT-WINDOW)))
    (AND (FUNCALL TW ':INCOMPLETE-P)
	 (FUNCALL TW ':SELECT))))

(DEFFLAVOR INSPECT-FRAME (INSPECTORS TYPEOUT-WINDOW (MENU NIL)) (BORDERED-CONSTRAINT-FRAME)
  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
  :GETTABLE-INSTANCE-VARIABLES
  (:INITABLE-INSTANCE-VARIABLES MENU)
  (:INIT-KEYWORDS :NUMBER-OF-INSPECTORS))

(DEFVAR INSPECT-FRAME-ITEM-LIST)
(SETQ INSPECT-FRAME-ITEM-LIST '(("Exit" . :EXIT)
				("Return" . :RETURN)
				("Modify" . :MODIFY)
				("DeCache" . :FLUSH-CACHE)
				("Clear" . :CLEAR)
				("Set \" . :SET-\)))

(DEFMETHOD (INSPECT-FRAME :BEFORE :INIT) (PLIST &AUX IO-BUFFER)
  (LET ((NOI (OR (GET PLIST ':NUMBER-OF-INSPECTORS) 3))
	(NAMES NIL))
    (SETQ IO-BUFFER (MAKE-DEFAULT-IO-BUFFER))
    (SETQ PANES (LIST `(INTERACTOR INTERACTION-PANE :LABEL NIL
				   		    :IO-BUFFER ,IO-BUFFER
						    :MORE-P NIL)
		      `(HISTORY INSPECT-HISTORY-PANE-WITH-MARGIN-SCROLLING
				:IO-BUFFER ,IO-BUFFER
				:SCROLL-BAR 3)
		      `(MENU COMMAND-MENU-PANE
			     :FONT-MAP ,(LIST FONTS:CPTFONT)
			     :ITEM-LIST ,INSPECT-FRAME-ITEM-LIST
			     :IO-BUFFER ,IO-BUFFER)))
    (DOTIMES (I NOI)
      (LET ((NAME (INTERN (FORMAT NIL "INSPECTOR-~D" I) "TV")))
	(PUSH `(,NAME ,(IF (= I (1- NOI))
			   'INSPECT-PANE-WITH-TYPEOUT
			   'INSPECT-PANE)
		:SCROLL-BAR 3
		:IO-BUFFER ,IO-BUFFER) PANES)
	(PUSH NAME NAMES)))
    (SETQ INSPECTORS NAMES)
    (SETQ CONSTRAINTS `((MAIN . ((INTERACTOR HIST-AND-MENU . ,(REVERSE NAMES))
				 ((HIST-AND-MENU :HORIZONTAL (:LIMIT (3 NIL :LINES HISTORY)
							      0.10s0 :LINES HISTORY)
				    (HISTORY MENU)
				    ((MENU :ASK :PANE-SIZE))
				    ((HISTORY :EVEN)))
				  (INTERACTOR 3 :LINES))
				 (,@(MAPCAR #'(LAMBDA (NAME)
						`(,NAME :LIMIT (1 30. :LINES)
						  ,(// 0.25s0 (1- NOI))
						  :LINES))
					    (CDR NAMES)))
				  ((,(CAR NAMES) :EVEN))))))))

(DEFMETHOD (INSPECT-FRAME :AFTER :INIT) (IGNORE &AUX INT)
  (FUNCALL-SELF ':SELECT-PANE (SETQ INT (FUNCALL-SELF ':GET-PANE 'INTERACTOR)))
  (DO ((IS INSPECTORS (CDR IS)))
      ((NULL IS))
    (RPLACA IS (FUNCALL-SELF ':GET-PANE (CAR IS))))
  (SETQ TYPEOUT-WINDOW (FUNCALL (CAR INSPECTORS) ':TYPEOUT-WINDOW))
  (FUNCALL TYPEOUT-WINDOW ':SET-IO-BUFFER (FUNCALL INT ':IO-BUFFER)))

(DEFMETHOD (INSPECT-FRAME :NAME-FOR-SELECTION) () NAME)

(COMPILE-FLAVOR-METHODS INSPECT-FRAME INTERACTION-PANE
			INSPECT-HISTORY-PANE INSPECT-HISTORY-PANE-WITH-MARGIN-SCROLLING
			INSPECT-PANE
			INSPECT-PANE-WITH-TYPEOUT INSPECT-TYPEOUT-WINDOW
			FOLLOW-LIST-STRUCTURE-BLINKER)

(DEFRESOURCE INSPECT-FRAME-RESOURCE
  (WINDOW-CREATE 'INSPECT-FRAME))

;;; User interface
(DEFUN INSPECT (&OPTIONAL OBJECT)
  (WITH-RESOURCE (INSPECT-FRAME-RESOURCE IF)
    (LET ((HW (FUNCALL IF ':GET-PANE 'HISTORY)))
      (COND (OBJECT
	     (WITH-SHEET-DEEXPOSED (IF)
	       (FUNCALL HW ':FLUSH-CONTENTS)
	       (FUNCALL HW ':APPEND-ITEM OBJECT)
	       (DOLIST (IW (FUNCALL IF ':INSPECTORS))
	         (FUNCALL IW ':SET-CURRENT-DISPLAY
			  (FUNCALL IW ':SETUP
				   `(INSPECT-PRINTER NIL NIL NIL
						     (NIL NIL NIL NIL
							  ,(LABEL-FONT (FUNCALL IW ':LABEL))
							  "Empty"))))
		 (FUNCALL IW ':SET-CURRENT-OBJECT (NCONS NIL))))))
      (FUNCALL (FUNCALL IF ':TYPEOUT-WINDOW) ':MAKE-COMPLETE)
      (FUNCALL HW ':CLEAR-INPUT)
      (*CATCH 'SI:TOP-LEVEL (INSPECT-TOP-LEVEL IF)))))

;;; The inspector top-level
(LOCAL-DECLARE ((SPECIAL \))
(DEFUN INSPECT-TOP-LEVEL (FRAME &AUX USER IS HISTORY)
  (WINDOW-CALL (FRAME :DEACTIVATE)
    (FUNCALL (SETQ USER (FUNCALL FRAME ':GET-PANE 'INTERACTOR)) ':CLEAR-SCREEN)
    (FUNCALL (CAR (SETQ IS (FUNCALL FRAME ':INSPECTORS))) ':FLUSH-TYPEOUT)
    (FUNCALL USER ':SET-OLD-TYPEAHEAD NIL)
    (SETQ HISTORY (FUNCALL FRAME ':GET-PANE 'HISTORY))
    ;; Flush remnants of modify mode
    (FUNCALL HISTORY ':SET-SENSITIVE-ITEM-TYPES T)
    (DOLIST (I IS)
      (FUNCALL I ':SET-MODIFY-MODE NIL))
    (DO ((TYPEOUT-WINDOW (FUNCALL FRAME ':TYPEOUT-WINDOW))
	 (TERMINAL-IO TERMINAL-IO)
	 (STANDARD-INPUT SI:SYN-TERMINAL-IO)
	 (STANDARD-OUTPUT SI:SYN-TERMINAL-IO)
	 (BUFFER (FUNCALL USER ':IO-BUFFER))
	 (\ NIL)
	 (THING) (TOP-ITEM))
	(())
      (LET ((ITEMS (FUNCALL HISTORY ':ITEMS))
	    (IW)
	    (IDX))
	(SETQ IDX (ARRAY-ACTIVE-LENGTH ITEMS))
	;; Make sure the inspection windows reflect the state of the history buffer
	(DOLIST (I IS)
	  ;; Update datastructure to reflect current TOP-ITEMs
	  (LET ((DISP (FUNCALL I ':CURRENT-DISPLAY)))
	    (AND DISP (SETF (FOURTH DISP) (FUNCALL I ':TOP-ITEM)))))
	(DOTIMES (I (LENGTH IS))
	  (SETQ IDX (1- IDX))
	  (SETQ IW (NTH I IS))
	  (COND ((< IDX 0)
		 (FUNCALL IW ':SET-CURRENT-DISPLAY
			  (FUNCALL IW ':SETUP
				   `(INSPECT-PRINTER NIL NIL NIL
						     (NIL NIL NIL NIL
							  ,(LABEL-FONT (FUNCALL IW ':LABEL))
							  "Empty"))))
		 (FUNCALL IW ':SET-CURRENT-OBJECT (NCONS NIL)))
		(T (FUNCALL HISTORY ':INSPECT-OBJECT (AREF ITEMS IDX) IW TOP-ITEM NIL T)
		   (SETQ TOP-ITEM NIL)))))

      ;; Insure last item in history is on the screen
      (FUNCALL HISTORY ':PUT-LAST-ITEM-IN-WINDOW)

      ;; Setup the value of * to be something useful
      (SETQ * (FUNCALL HISTORY ':LAST-ITEM))

      ;; Get input
      (UNWIND-PROTECT
	(PROGN
	  (SETF (IO-BUFFER-OUTPUT-FUNCTION BUFFER) NIL)
	  (DO ((FLAG)) (())
	    (SETQ THING -1
		  TERMINAL-IO TYPEOUT-WINDOW)
	    (FUNCALL (CAR IS) ':FLUSH-TYPEOUT)
	    (FUNCALL FRAME ':SELECT-PANE USER)
	    (FUNCALL USER ':FRESH-LINE)
	    (OR (FUNCALL USER ':OLD-TYPEAHEAD)
		(SETQ THING (FUNCALL USER ':ANY-TYI)))
	    (COND ((NOT (NUMBERP THING))
		   ;; Some sort of mouse command, just process
		   (RETURN))
		  ((= (CHAR-UPCASE THING) #/Z)
		   (*THROW 'SI:TOP-LEVEL NIL))
		  ((= THING #\BREAK)
		   (FUNCALL FRAME ':SELECT-PANE (CAR IS))
		   (FUNCALL TERMINAL-IO ':EXPOSE-FOR-TYPEOUT)
		   (*CATCH 'SI:TOP-LEVEL (BREAK INSPECT)))
		  ((= THING #\RUBOUT))
		  ((= THING #\QUOTE)
		   (SETQ TERMINAL-IO USER)
		   (FORMAT USER "Eval: ")
		   (MULTIPLE-VALUE (THING FLAG)
		     (FUNCALL USER ':RUBOUT-HANDLER
			      '((:FULL-RUBOUT :FULL-RUBOUT)) #'SI:READ-FOR-TOP-LEVEL))
		   (OR (EQ FLAG ':FULL-RUBOUT)
		       (NULL (SETQ THING (ERRSET (EVAL THING))))
		       (LET ((PRINLEVEL 3) (PRINLENGTH 5))
			 (SETQ * (PRINT (CAR THING) USER)))))
		  (T
		   (SETQ TERMINAL-IO USER)
		   (AND ( THING 0) (FUNCALL USER ':UNTYI THING))
		   (MULTIPLE-VALUE (THING FLAG)
		     (FUNCALL USER ':PREEMPTABLE-READ
			      '((:FULL-RUBOUT :FULL-RUBOUT)) #'SI:READ-FOR-TOP-LEVEL))
		   (AND (EQ FLAG ':MOUSE-CHAR)
			(RETURN))
		   (IF (EQ FLAG ':FULL-RUBOUT)
		       NIL
		       (SETQ THING (ERRSET (EVAL THING) T))
		       (AND THING
			    (RETURN (SETQ THING
					  `(:VALUE ,(SETQ * (CAR THING)) ,HISTORY)))))))))
	(SETF (IO-BUFFER-OUTPUT-FUNCTION BUFFER) 'KBD-DEFAULT-OUTPUT-FUNCTION))
      (SETQ TERMINAL-IO TYPEOUT-WINDOW)

      (SELECTQ (FIRST THING)
	(:MENU
	 (SELECTQ (CDR (SECOND THING))
	   (:EXIT (RETURN NIL))
	   (:RETURN
	    (FORMAT USER "~&Value to return ")
	    (MULTIPLE-VALUE-BIND (VALUE PUNT-P)
		(INSPECT-GET-VALUE-FROM-USER USER)
	      (OR PUNT-P (RETURN VALUE))))
	   (:INSPECT
	    (FORMAT USER "~&Thing to be inspected (type a form to be evaled, NIL aborts): ")
	    (LET ((THING (LET ((STANDARD-INPUT USER) (TERMINAL-IO USER))
			   (ERRSET (EVAL (SI:READ-FOR-TOP-LEVEL)) T))))
	      (TERPRI USER)
	      (AND THING (CAR THING)
		   (FUNCALL HISTORY ':FORCE-KBD-INPUT `(:VALUE ,(CAR THING) ,(CAR IS))))))
	   (:FLUSH-CACHE
	    (FUNCALL HISTORY ':SET-CACHE NIL))
	   (:MODIFY
	    (SETQ TOP-ITEM (INSPECT-MODIFY-OBJECT USER HISTORY IS)))
	   (:CLEAR
	    (FUNCALL HISTORY ':FLUSH-CONTENTS))
	   (:SET-\
	    (FORMAT USER "~&Value to set \ to ")
	    (MULTIPLE-VALUE-BIND (VALUE PUNT-P)
		(INSPECT-GET-VALUE-FROM-USER USER)
	      (OR PUNT-P (SETQ \ VALUE))))
	   (OTHERWISE (FORMAT USER "~&Unimplemented menu command ~A~%" (SECOND THING)))))
	(OTHERWISE
	 (COND ((NULL (FIRST THING))
		;; Type is NIL -- nothing under mouse
		(BEEP))
	       ((AND (EQ (FIRST THING) ':LINE-AREA) (EQ (FOURTH THING) #\MOUSE-2-1))
		;; Delete from line area
		(FUNCALL HISTORY ':FLUSH-OBJECT (INSPECT-REAL-VALUE THING)))
	       ((OR (NULL (FOURTH THING)) (= (FOURTH THING) #\MOUSE-1-1))
		(SETQ THING (INSPECT-REAL-VALUE THING))
		(INSPECT-FLUSH-FROM-HISTORY THING HISTORY)
		(FUNCALL HISTORY ':APPEND-ITEM THING))
	       ((= (FOURTH THING) #\MOUSE-2-1)
		;; Middle click means leave source in one of the windows
		(LET ((1ST-THING (INSPECT-REAL-VALUE THING))
		      (2ND-THING (FUNCALL (THIRD THING) ':CURRENT-OBJECT)))
		  ;; First flush item we will be inspecting
		  (INSPECT-FLUSH-FROM-HISTORY 1ST-THING HISTORY)
		  (INSPECT-FLUSH-FROM-HISTORY 2ND-THING HISTORY)
		  (FUNCALL HISTORY ':APPEND-ITEM 2ND-THING)
		  (FUNCALL HISTORY ':APPEND-ITEM 1ST-THING)))
	       ((= (FOURTH THING) #\MOUSE-3-1)
		;; Click on right button -- try to find function
		(SETQ THING (INSPECT-FIND-FUNCTION (INSPECT-REAL-VALUE THING)))
		(INSPECT-FLUSH-FROM-HISTORY THING HISTORY)
		(FUNCALL HISTORY ':APPEND-ITEM THING)))))))))


(DEFUN INSPECT-FLUSH-FROM-HISTORY (THING HISTORY)
  (LET ((ITEMS (FUNCALL HISTORY ':ITEMS)))
    (DOTIMES (I (ARRAY-ACTIVE-LENGTH ITEMS))
      (AND (EQ THING (AREF ITEMS I))
	   (RETURN (FUNCALL HISTORY ':DELETE-ITEM I))))))

(DEFUN INSPECT-REAL-VALUE (THING)
  (SELECTQ (FIRST THING)
    ((:VALUE :LINE-AREA 1D-ARRAY-SLOT LEADER-SLOT) (SECOND THING))
    (:LOCATIVE (CDR (SECOND THING)))
    (:LIST-STRUCTURE-TOP-LEVEL (FUNCALL (THIRD THING) ':CURRENT-OBJECT))
    (:LIST-STRUCTURE (CDR (FIRST (SECOND THING))))
    (OTHERWISE (THIRD (SECOND THING)))))

(DEFUN INSPECT-GET-VALUE-FROM-USER (TERMINAL-IO)
  (FORMAT TERMINAL-IO "(type a form to be evaled or select something with mouse): ")
  (PROG ()
	(LET ((THING (FUNCALL TERMINAL-IO ':ANY-TYI)))
	  (COND ((LISTP THING)
		 ;; Choose somthing with the mouse -- display it truncated and proceed
		 (COND ((EQ (FIRST THING) ':MENU)
			(FORMAT TERMINAL-IO "~&Cannot set value from the menu~%")
			(RETURN NIL T)))
		 (LET ((PRINLEVEL 3) (PRINLENGTH 5))
		   (PRIN1 (SETQ THING (INSPECT-REAL-VALUE THING)) TERMINAL-IO)))
		(T
		 (FUNCALL TERMINAL-IO ':UNTYI THING)
		 (SETQ THING (ERRSET (EVAL (LET ((STANDARD-INPUT TERMINAL-IO))
					     (SI:READ-FOR-TOP-LEVEL)))
				     T))
		 (OR THING (RETURN NIL T))	;Failed to eval, punt
		 (SETQ THING (CAR THING))))	   
	  (TERPRI TERMINAL-IO)
	  (RETURN THING))))

(DEFUN INSPECT-MODIFY-OBJECT (TERMINAL-IO HISTORY &OPTIONAL (INSPECTORS NIL) &AUX THING OSIT)
  (SETQ OSIT (FUNCALL HISTORY ':SENSITIVE-ITEM-TYPES))
  (UNWIND-PROTECT
    (PROGN
      (FUNCALL HISTORY ':SET-SENSITIVE-ITEM-TYPES NIL)
      (DOLIST (I INSPECTORS)
	(FUNCALL I ':SET-MODIFY-MODE T))
      (FORMAT TERMINAL-IO "~&Pick a slot, with the mouse, to modify")
      (SETQ THING (FUNCALL TERMINAL-IO ':LIST-TYI)))
    (FUNCALL HISTORY ':SET-SENSITIVE-ITEM-TYPES OSIT)
    (DOLIST (I INSPECTORS)
      (FUNCALL I ':SET-MODIFY-MODE NIL)))
  (LET ((SET-FUNCTION (GET (FIRST THING) 'SET-FUNCTION)))
    (IF (OR (NULL (FIRST THING)) (NULL SET-FUNCTION) (EQ (FOURTH THING) #\MOUSE-3-1))
	(FORMAT TERMINAL-IO "~&Aborted.~%")
	(FORMAT TERMINAL-IO "~&New value ")
	(MULTIPLE-VALUE-BIND (NEW-VALUE PUNT-P)
	    (INSPECT-GET-VALUE-FROM-USER TERMINAL-IO)
	  (OR PUNT-P
	      (FUNCALL SET-FUNCTION THING NEW-VALUE
		       (FUNCALL (THIRD THING) ':CURRENT-OBJECT))))
	;; We must recompute object we modified
	(FUNCALL HISTORY ':FLUSH-OBJECT-FROM-CACHE 
		 (FUNCALL (THIRD THING) ':CURRENT-OBJECT))
	(PROG1 (FUNCALL (THIRD THING) ':TOP-ITEM)
	       (FUNCALL (THIRD THING) ':SET-CURRENT-OBJECT (NCONS NIL))))))

(DEFUN INSPECT-FIND-FUNCTION (THING)
  (DO () (())
      (SETQ THING
	    (COND ((SYMBOLP THING)
		   (IF (FBOUNDP THING)
		       (FSYMEVAL THING)
		       (RETURN THING)))
		  ((EQ (DATA-TYPE THING) 'DTP-INSTANCE)
		   (%P-CONTENTS-OFFSET (%P-CONTENTS-AS-LOCATIVE-OFFSET THING 0)
				       %INSTANCE-DESCRIPTOR-FUNCTION))
		  ((OR (EQ (DATA-TYPE THING) 'DTP-ENTITY)
		       (EQ (DATA-TYPE THING) 'DTP-CLOSURE))
		   (CAR (%MAKE-POINTER DTP-LIST THING)))
		  (T (RETURN THING))))))