;;;The hairy window error handler -*- Mode:LISP; Package:EH -*-
;;;THIS SHOULD BE AN EDITOR TOP LEVEL UNDER SOME SWITCH
(DEFFLAVOR ERROR-HANDLER-LISP-LISTENER-PANE ()
	   (TV:PANE-MIXIN TV:PREEMPTABLE-READ-ANY-TYI-MIXIN TV:DONT-SELECT-WITH-MOUSE-MIXIN
	    TV:NOTIFICATION-MIXIN TV:AUTOEXPOSING-MORE-MIXIN TV:WINDOW)
  (:DOCUMENTATION :COMBINATION "The read-eval-print window in the window error handler"))

(DEFFLAVOR ERROR-HANDLER-TEXT-SCROLL-PANE ()
	   TV:(PANE-MIXIN FUNCTION-TEXT-SCROLL-WINDOW MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW
	       FLASHY-SCROLLING-MIXIN DONT-SELECT-WITH-MOUSE-MIXIN BORDERS-MIXIN
	       TOP-LABEL-MIXIN ESSENTIAL-WINDOW)
	   (:DOCUMENTATION :COMBINATION "Scroll windows for the window error handler"))

(DEFFLAVOR GRAY-ERROR-HANDLER-TEXT-SCROLL-PANE () (TV:TEXT-SCROLL-WINDOW-EMPTY-GRAY-HACK
						   ERROR-HANDLER-TEXT-SCROLL-PANE)
  (:DOCUMENTATION :COMBINATION "Args and locals windows in window error handler"))

(DEFFLAVOR STACK-SCROLL-PANE 
	((PRINLENGTH ERROR-MESSAGE-PRINLENGTH)
	 (PRINLEVEL ERROR-MESSAGE-PRINLEVEL))
	(TV:CURRENT-ITEM-MIXIN TV:LINE-AREA-MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW
	 TV:MARGIN-SCROLL-MIXIN
	 ERROR-HANDLER-TEXT-SCROLL-PANE)
  (:DOCUMENTATION :COMBINATION "Stack window in the window error handler"))

(DEFFLAVOR ERROR-HANDLER-FRAME
	(INSPECT-WINDOW				;Where the disassembled code goes
	 INSPECT-HISTORY-WINDOW			;History for the inspector
	 ARGS-WINDOW				;The arguments
	 LOCALS-WINDOW				;The locals
	 STACK-WINDOW				;Backtrace
	 COMMAND-MENU-WINDOW			;The command menu
	 LISP-WINDOW				;A read-eval-print loop window
	 FRAME-ALIST				;Saved frame layout
	 )
	(TV:BORDERED-CONSTRAINT-FRAME)
  (:GETTABLE-INSTANCE-VARIABLES LISP-WINDOW)
  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
  (:DOCUMENTATION :SPECIAL-PURPOSE "Controls layout of window error handler panes"))

(DEFVAR COMMAND-ALIST
	'(("What Error" . COMW-WHAT-ERROR)
	  ("Arglist" . COMW-ARGLIST)
	  ("Retry" . COM-RETURN-REINVOCATION)
	  ("Set arg" . COMW-SET-ARG)
	  ("T" . T)
	  ("Quit one level" . COM-THROW-ONE-ERROR)
	  ("Inspect" . COMW-INSPECT)
	  ("Return a value" . COM-RETURN-A-VALUE)
	  ("Search" . COMW-SEARCH)
	  ("NIL" . NIL-VALUE)
	  ("Exit" . COM-TOP-LEVEL-THROW)
	  ("Edit" . COMW-EDIT)
	  ("Continue" . COM-PROCEED)
	  ("Throw" . COM-THROW)))

(DEFMETHOD (ERROR-HANDLER-FRAME :BEFORE :INIT) (IGNORE &AUX IO-BUFFER)
  (SETQ IO-BUFFER (TV:MAKE-DEFAULT-IO-BUFFER))
  (SETQ TV:SELECTED-PANE 'LISP-WINDOW
	TV:PANES `((LISP-WINDOW ERROR-HANDLER-LISP-LISTENER-PANE :LABEL NIL
								 :IO-BUFFER ,IO-BUFFER)
		   (ARGS-WINDOW GRAY-ERROR-HANDLER-TEXT-SCROLL-PANE :LABEL "Args:"
				:IO-BUFFER ,IO-BUFFER)
		   (LOCALS-WINDOW GRAY-ERROR-HANDLER-TEXT-SCROLL-PANE
				  :LABEL "Locals:" :IO-BUFFER ,IO-BUFFER)
		   (STACK-WINDOW STACK-SCROLL-PANE
				 :MARGIN-SCROLL-REGIONS ((:TOP "Bottom of stack")
							 (:BOTTOM "Top of stack"))
				 :FLASHY-SCROLLING-REGION ((20 0.40s0 0.60s0)
							   (20 0.40s0 0.60s0))
				 :LABEL NIL :IO-BUFFER ,IO-BUFFER)
		   (COMMAND-MENU-WINDOW TV:COMMAND-MENU-PANE :ITEM-LIST ,COMMAND-ALIST
					:IO-BUFFER ,IO-BUFFER)
		   (INSPECT-WINDOW TV:INSPECT-PANE :IO-BUFFER ,IO-BUFFER
				   		   :LABEL FONTS:CPTFONT)
		   (INSPECT-HISTORY-WINDOW TV:INSPECT-HISTORY-PANE
					   :IO-BUFFER ,IO-BUFFER))


	TV:CONSTRAINTS
	'((ERROR-HANDLER-CONFIGURATION . ((INSPECT-WINDOW INSPECT-HISTORY-WINDOW ARGS-LOCS
					   STACK-WINDOW COMMAND-MENU-WINDOW LISP-WINDOW)
					  ((LISP-WINDOW 0.15s0 :LINES)
					   (COMMAND-MENU-WINDOW :ASK :PANE-SIZE)
					   (INSPECT-HISTORY-WINDOW 3 :LINES))
					  ((INSPECT-WINDOW 0.33s0 :LINES)
					   (ARGS-LOCS :HORIZONTAL (0.33s0 :LINES ARGS-WINDOW)
						      (ARGS-WINDOW LOCALS-WINDOW)
						      ((ARGS-WINDOW :EVEN)
						       (LOCALS-WINDOW :EVEN))))
					  ((STACK-WINDOW :EVEN))))
	  (ERROR-HANDLER-OLD-CONFIGURATION . ((INSPECT-WINDOW ARGS-LOCS STACK-WINDOW
							      COMMAND-MENU-WINDOW LISP-WINDOW)
					      ((LISP-WINDOW 0.25s0 :LINES)
					       (COMMAND-MENU-WINDOW :ASK :PANE-SIZE))
					      ((INSPECT-WINDOW 0.33s0) 
					       (ARGS-LOCS :HORIZONTAL (0.33s0)
							  (ARGS-WINDOW LOCALS-WINDOW)
							  ((ARGS-WINDOW :EVEN)
							   (LOCALS-WINDOW :EVEN))))
					      ((STACK-WINDOW :EVEN)))))))

(DEFMETHOD (ERROR-HANDLER-FRAME :AFTER :INIT) (IGNORE)
  (DOLIST (PANE TV:INTERNAL-PANES)
    (SET (CAR PANE) (CDR PANE))))

(DEFMETHOD (ERROR-HANDLER-FRAME :INSPECT-WINDOW-P) (W)
  (OR (EQ W INSPECT-HISTORY-WINDOW) (EQ W INSPECT-WINDOW)))

(DEFMETHOD (ERROR-HANDLER-FRAME :SELECT) (&REST ARGS)
  (LEXPR-FUNCALL LISP-WINDOW ':SELECT ARGS)
  (FUNCALL-SELF ':EXPOSE))

(DEFMETHOD (ERROR-HANDLER-FRAME :DESELECT) (&REST ARGS)
  (LEXPR-FUNCALL LISP-WINDOW ':DESELECT ARGS))

(DEFMETHOD (ERROR-HANDLER-FRAME :NAME-FOR-SELECTION) () TV:NAME)

(DEFMETHOD (ERROR-HANDLER-FRAME :SET-SENSITIVE-ITEM-TYPES) (VAL)
  (FUNCALL ARGS-WINDOW ':SET-SENSITIVE-ITEM-TYPES VAL)
  (FUNCALL LOCALS-WINDOW ':SET-SENSITIVE-ITEM-TYPES VAL)
  (FUNCALL STACK-WINDOW ':SET-SENSITIVE-ITEM-TYPES VAL))

(DEFMETHOD (ERROR-HANDLER-FRAME :INSPECT-OBJECT) (THING)
  (FUNCALL INSPECT-HISTORY-WINDOW ':INSPECT-OBJECT THING INSPECT-WINDOW))

(DEFMETHOD (ERROR-HANDLER-FRAME :SETUP-SG) (SG AP)
  (SETQ FRAME-ALIST NIL)
  (FUNCALL INSPECT-HISTORY-WINDOW ':FLUSH-CONTENTS)
  (SETUP-STACK-FRAME-WINDOW STACK-WINDOW SG)
  (FUNCALL-SELF ':SETUP-FRAME SG AP))

(DEFMETHOD (ERROR-HANDLER-FRAME :SETUP-FRAME) (SG AP &OPTIONAL FORCE-P
						     &AUX CODE ARGS LOCALS TEM)
  (OR TV:EXPOSED-P
      ;; If window not exposed, get its bit array in core so setup will go faster
      (SI:PAGE-IN-ARRAY TV:SCREEN-ARRAY))
  (SETQ TEM (ASSQ AP FRAME-ALIST))
  (COND (FORCE-P
	 (SETQ FRAME-ALIST (DELQ TEM FRAME-ALIST))
	 (SETQ TEM NIL)))
  ;; Set stuff up in most interesting order: args, then locals, then code
  (COND (TEM					;Displayed this before
	 (FUNCALL ARGS-WINDOW ':SETUP (THIRD TEM))
	 (FUNCALL LOCALS-WINDOW ':SETUP (FOURTH TEM))
	 (FUNCALL INSPECT-HISTORY-WINDOW ':INSPECT-OBJECT (SECOND TEM) INSPECT-WINDOW))
	(T
	 (MULTIPLE-VALUE (ARGS TEM) (SETUP-ARGS-WINDOW ARGS-WINDOW SG AP))
	 (SETQ LOCALS (SETUP-LOCALS-WINDOW LOCALS-WINDOW SG AP TEM))
	 (SETQ CODE (SETUP-INSPECT-WINDOW INSPECT-WINDOW SG AP INSPECT-HISTORY-WINDOW))
	 (PUSH (LIST AP CODE ARGS LOCALS) FRAME-ALIST)))
  (FUNCALL STACK-WINDOW ':PUT-ITEM-IN-WINDOW AP)
  (FUNCALL STACK-WINDOW ':SET-CURRENT-ITEM AP))

;;;Support routines for the stack frame window, a stack frame entry is just an AP.
;;;The common argument is the stack group.
(DEFUN SETUP-STACK-FRAME-WINDOW (WINDOW SG &AUX LIST)
  (DO ((AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG AP)))
      ((NULL AP))
    (PUSH AP LIST))	;No NREVERSE below, note.
  (FUNCALL WINDOW ':SETUP (LIST 'PRINT-STACK-FRAME SG LIST)))

;;; Given an SG and an AP, return the function and first and last+1 arg index into the RP
;;; (3 values).
(DEFUN STACK-FRAME-FUNCTION-AND-ARGS (SG AP)
  (DECLARE (RETURN-LIST FUNCTION ARGS-START ARGS-END))
  (PROG* ((RP (SG-REGULAR-PDL SG))
	  (FUNCTION (RP-FUNCTION-WORD RP AP)))
    ;;If SELF is bound by this frame to an object whose handler for the first argument to this
    ;;frame is the function of this frame, print that object instead.
    (LET ((IDX (SG-FRAME-SPECIAL-PDL-RANGE SG AP)))
      (AND IDX
	   (> IDX 0)
	   (LET ((SP (SG-SPECIAL-PDL SG)))
	     (AND (EQ (AREF SP (1+ IDX))
		      (%MAKE-POINTER DTP-LOCATIVE (%P-LDB-OFFSET %%Q-POINTER 'SELF 1)))
		  (LET* ((OBJECT (AREF SP IDX))
			 (HANDLER (GET-HANDLER-FOR OBJECT (AREF RP (1+ AP)))))
		    (AND (IF HANDLER
			     (EQ FUNCTION (IF (SYMBOLP HANDLER) (FSYMEVAL HANDLER) HANDLER))
			     (EQ FUNCTION #'SI:UNCLAIMED-MESSAGE))
			 (SETQ FUNCTION OBJECT)))))))
    (RETURN FUNCTION (1+ AP) (+ AP (RP-NUMBER-ARGS-SUPPLIED RP AP) 1))))

;;;Return the range of the special pdl bound by this frame, or NIL if does not hack any
;;;specials.
(DEFUN SG-FRAME-SPECIAL-PDL-RANGE (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)))
  (AND (NOT (ZEROP (RP-BINDING-BLOCK-PUSHED RP FRAME)))
       (LET ((SP (SG-SPECIAL-PDL SG)))
	 (DO ((AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG AP))
	      (J (SG-SPECIAL-PDL-POINTER SG))
	      (I))
	     ((NULL AP))
	   (COND ((NOT (ZEROP (RP-BINDING-BLOCK-PUSHED RP AP)))
		  (DO () ((= (%P-DATA-TYPE (ALOC-CAREFUL SP J)) DTP-LOCATIVE))
		    ;; Space back over a random non-binding frame
		    (DO () ((NOT (ZEROP (%P-FLAG-BIT (ALOC-CAREFUL SP J)))))
		      (SETQ J (1- J)))
		    (SETQ J (1- J)))
		  ;; Make I and J inclusive brackets for this binding frame
		  (SETQ I (1- J))
		  (DO () ((NOT (ZEROP (%P-FLAG-BIT (ALOC-CAREFUL SP I)))))
		    (SETQ I (- I 2)))
		  (AND (= AP FRAME) (RETURN I J))
		  (SETQ J (1- I))))))))

;;;Print a frame  (ITEM is AP)
(DEFUN PRINT-STACK-FRAME (ITEM SG STREAM IGNORE)
  (FUNCALL STREAM ':ITEM ITEM 'STACK-FRAME #'PRINT-STACK-FRAME-1 SG))

(DEFUN PRINT-STACK-FRAME-1 (AP STREAM SG)
  (MULTIPLE-VALUE-BIND (FUNCTION ARGS-START ARGS-END) (STACK-FRAME-FUNCTION-AND-ARGS SG AP)
    (FUNCALL STREAM ':TYO (SI:PTTBL-OPEN-PAREN READTABLE))
    (FUNCALL STREAM ':ITEM FUNCTION ':FUNCTION #'(LAMBDA (FUNCTION STREAM)
						   (PRIN1 (FUNCTION-NAME FUNCTION) STREAM)))
    (DO ((I ARGS-START (1+ I))
	 (L 1 (1+ L))
	 (RP (SG-REGULAR-PDL SG)))
	(( I ARGS-END)
	 (FUNCALL STREAM ':TYO (SI:PTTBL-CLOSE-PAREN READTABLE)))
      (FUNCALL STREAM ':TYO (SI:PTTBL-SPACE READTABLE))
      (FUNCALL STREAM ':ITEM (AREF RP I) ':VALUE #'TV:PRINT-ITEM-CONCISELY)
      (COND ((AND PRINLENGTH ( L PRINLENGTH))
	     (FUNCALL STREAM ':STRING-OUT (SI:PTTBL-PRINLENGTH READTABLE))
	     (RETURN NIL))))))

;;;Support routines for the args, locals, and specials windows
;;;Entries are fixed strings, or lists of name, val, and number
;;;Common arg is the type of entries present
(DEFUN SETUP-ARGS-WINDOW (WINDOW SG AP &AUX (RP (SG-REGULAR-PDL SG)) LIST
					    FUNCTION NARGS-SUPPLIED NARGS-TO-PRINT
					    NARGS-EXPECTED NARGS-REQUIRED
					    LEXPR-CALL REST-ARG-P REST-ARG-VALUE)
  (SETQ FUNCTION (RP-FUNCTION-WORD RP AP)
	NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP))
  (COND ((OR (= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER) (LISTP FUNCTION))
	 (SETQ NARGS-REQUIRED
	       (LDB %%ARG-DESC-MIN-ARGS (ARGS-INFO FUNCTION)))
	 (SETQ NARGS-EXPECTED
	       (LDB %%ARG-DESC-MAX-ARGS (ARGS-INFO FUNCTION)))))
  (MULTIPLE-VALUE (REST-ARG-VALUE REST-ARG-P LEXPR-CALL)
    (SG-REST-ARG-VALUE SG AP))
  (SETQ NARGS-TO-PRINT (SG-NUMBER-OF-SPREAD-ARGS SG AP))
  ;; Store the individual args.
  (DOTIMES (I NARGS-TO-PRINT)
    (AND (= I NARGS-SUPPLIED)			;These "args" weren't supplied
	 (PUSH (IF (AND NARGS-REQUIRED (< I NARGS-REQUIRED))
		   "   --Missing args:--" "   --Defaulted args:--")
	       LIST))
    (AND NARGS-EXPECTED (= I NARGS-EXPECTED)	;Called with too many args
	 (PUSH "   --Extraneous args:--" LIST))
    (LET ((MISSING (AND NARGS-REQUIRED
			(> NARGS-REQUIRED NARGS-SUPPLIED)
			( I NARGS-SUPPLIED))))
      (PUSH (LIST (ARG-NAME FUNCTION I)	;Arg name
		  (OR MISSING (AREF RP (+ AP I 1)))	;Value
		  (IF (NOT MISSING) I (LIST ':NOVALUE I))) ;Number
	    LIST)))
  ;; Print the rest arg if any.
  (AND (OR REST-ARG-P LEXPR-CALL)
       (PUSH (LIST (AND REST-ARG-P (LOCAL-NAME FUNCTION 0))	;Name
		   REST-ARG-VALUE	;Value
		   (IF REST-ARG-P "Rest arg" "Extraneous rest arg"))
	     LIST))
  (PROG () (RETURN (FUNCALL WINDOW ':SETUP (LIST 'PRINT-ARG-OR-LOCAL '(ARG "Arg")
						 (NREVERSE LIST)))
		   REST-ARG-P)))

;;;REST-ARG-P means that local 0 is in the other window and should not be duplicated
(DEFUN SETUP-LOCALS-WINDOW (WINDOW SG AP REST-ARG-P &AUX (RP (SG-REGULAR-PDL SG))
							 LIST FUNCTION START END VAL)
  (SETQ FUNCTION (RP-FUNCTION-WORD RP AP))
  (AND (= DTP-FEF-POINTER (%DATA-TYPE FUNCTION))
       ;; Print the locals if this is a fef
       (DO ((N-LOCALS (FEF-NUMBER-OF-LOCALS FUNCTION))
	    (I 0 (1+ I))
	    (J (+ AP (RP-LOCAL-BLOCK-ORIGIN RP AP)) (1+ J)))
	   (( I N-LOCALS))
	 (COND ((NOT (AND REST-ARG-P (ZEROP I)))	;Don't show rest arg twice
		(PUSH (LIST (LOCAL-NAME FUNCTION I)	;Name
			    (AREF RP J)		;Value
			    I)			;Number
		      LIST)))))
  (MULTIPLE-VALUE (START END)
    (SG-FRAME-SPECIAL-PDL-RANGE SG AP))
  (COND (START
	 (PUSH "" LIST)
	 (PUSH "Specials:" LIST)
	 (DO ((I START (+ I 2))
	      (SP (SG-SPECIAL-PDL SG)))
	     (( I END))
	   (PUSH (LIST (SYMBOL-FROM-VALUE-CELL-LOCATION (AREF SP (1+ I)))	;Name
		       (IF (SETQ VAL (ERRSET (AREF SP I) NIL))			;Value
			   (CAR VAL)
			   "unbound"))
		 LIST))))
  (FUNCALL WINDOW ':SETUP (LIST 'PRINT-ARG-OR-LOCAL '(LOCAL "Local") (NREVERSE LIST))))

(DEFUN SYMBOL-FROM-VALUE-CELL-LOCATION (LOC &AUX SYM)
  (COND ((AND ( (%POINTER LOC) A-MEMORY-VIRTUAL-ADDRESS)	;Microcode location
	      (< (%POINTER LOC) IO-SPACE-VIRTUAL-ADDRESS))	; forwarded from value cell
	 (OR (DOLIST (SYM A-MEMORY-LOCATION-NAMES)
	       (AND (= (%POINTER LOC) (%P-LDB-OFFSET %%Q-POINTER SYM 1)) (RETURN SYM)))
	     (DOLIST (SYM M-MEMORY-LOCATION-NAMES)
	       (AND (= (%POINTER LOC) (%P-LDB-OFFSET %%Q-POINTER SYM 1)) (RETURN SYM)))
	     LOC))
	((AND (SYMBOLP (SETQ SYM (%FIND-STRUCTURE-HEADER LOC)))	;Regular symbol's
	      (= (%POINTER-DIFFERENCE LOC SYM) 1))		; internal value-cell
	 SYM)
	(T LOC)))						;not a symbol

(COMMENT
(DEFUN PRINT-SPECIAL-PDL-RANGE (SG START END &OPTIONAL (STREAM STANDARD-OUTPUT))
  (DO ((SP (SG-SPECIAL-PDL SG))
       (I START (+ I 2)))
      (( I END))
    (FORMAT STREAM "~&~S: ~S~%" (SYMBOL-FROM-VALUE-CELL-LOCATION (AREF SP (1+ I)))
				(AREF SP I))))
)

(DEFUN PRINT-ARG-OR-LOCAL (ITEM TYPE STREAM IGNORE &AUX NUMBER NAME VALUE TYPE-NAME NOVALUE)
  (IF (STRINGP ITEM)
      (FUNCALL STREAM ':STRING-OUT ITEM)
      (SETQ TYPE-NAME (SECOND TYPE)
	    TYPE (FIRST TYPE)
	    NAME (FIRST ITEM)
	    VALUE (SECOND ITEM)
	    NUMBER (THIRD ITEM))
      (AND (LISTP NUMBER) (SETQ NOVALUE (FIRST NUMBER) NUMBER (SECOND NUMBER)))
      (COND ((NULL NUMBER))
	    ((STRINGP NUMBER) (FUNCALL STREAM ':STRING-OUT NUMBER))
	    (T (FORMAT STREAM "~A ~D" TYPE-NAME NUMBER)))
      (AND NAME
	   (COND (NUMBER
		  (FUNCALL STREAM ':STRING-OUT " (")
		  (FUNCALL STREAM ':ITEM (LIST NAME NUMBER) TYPE
				  #'(LAMBDA (X STREAM)
				      (FUNCALL STREAM ':STRING-OUT (GET-PNAME (CAR X)))))
		  (FUNCALL STREAM ':TYO #/)))
		 (T
		  (FUNCALL STREAM ':ITEM NAME TYPE))))
      (COND ((NEQ NOVALUE ':NOVALUE)
	     (FUNCALL STREAM ':STRING-OUT ": ")
	     (FUNCALL STREAM ':ITEM VALUE ':VALUE)))))

;;;Support routines for the code window
(DEFUN SETUP-INSPECT-WINDOW (INSPECT-WINDOW SG AP INSPECT-HISTORY-WINDOW
			     &AUX FUNCTION (LABEL "") CODE)
  (SETQ FUNCTION (RP-FUNCTION-WORD (SG-REGULAR-PDL SG) AP))
  (AND (NLISTP FUNCTION)			;Print nothing for interpreted code
       (LET ((NAME (FUNCTION-NAME FUNCTION)))
	 (SETQ LABEL (COND ((STRINGP NAME) NAME)
			   ((SYMBOLP NAME) (GET-PNAME NAME))
			   (T (FORMAT NIL "~S" NAME))))))
  (FUNCALL INSPECT-HISTORY-WINDOW ':INSPECT-OBJECT
	   (SETQ CODE (TV:MAKE-STACK-FRAME TV:STACK-FRAME-SG SG
					   TV:STACK-FRAME-AP AP
					   TV:STACK-FRAME-FUNCTION-NAME LABEL))
	   INSPECT-WINDOW)
  CODE)

;;;Entry from the other error handler
(DEFUN COM-WINDOW-ERROR-HANDLER (SG ETE)
  (FORMAT T "Window error handler!~%")
  (WINDOW-COMMAND-LOOP SG ETE))

(COMPILE-FLAVOR-METHODS ERROR-HANDLER-FRAME ERROR-HANDLER-LISP-LISTENER-PANE
			ERROR-HANDLER-TEXT-SCROLL-PANE GRAY-ERROR-HANDLER-TEXT-SCROLL-PANE
			STACK-SCROLL-PANE)

;;;The actual window
(DEFVAR ERROR-HANDLER-WINDOW)
(ADD-INITIALIZATION "EHW" '(SETQ ERROR-HANDLER-WINDOW (TV:WINDOW-CREATE 'ERROR-HANDLER-FRAME))
		    '(:ONCE))

;;;The command loop
(DEFUN WINDOW-COMMAND-LOOP (ERROR-SG ETE
			    &AUX SPECIAL-CHAR SEXP (EVALHOOK NIL) PKG (BASE 8) (IBASE 8)
				 (*NOPOINT NIL) (PACKAGE PACKAGE) (WINDOW-ERROR-HANDLER T)
				 (TERMINAL-IO (FUNCALL ERROR-HANDLER-WINDOW ':LISP-WINDOW)))
  (FUNCALL ERROR-HANDLER-WINDOW ':SETUP-SG ERROR-SG CURRENT-FRAME)
  (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
  (TV:WINDOW-CALL (ERROR-HANDLER-WINDOW)
    (SETQ WINDOW-ERROR-HANDLER (OR TV:.CURRENT-WINDOW. T))
    (PRINT-ERROR-MESSAGE ERROR-SG ETE T)
    (FUNCALL TERMINAL-IO ':CLEAR-INPUT)
    (DO ((-)
	 (+ (SYMEVAL-IN-STACK-GROUP '- ERROR-SG))
	 (* (SYMEVAL-IN-STACK-GROUP '* ERROR-SG)))
	(NIL)
      (SETQ PKG (SYMEVAL-IN-STACK-GROUP 'PACKAGE ERROR-SG))
      (SETQ PACKAGE (IF (EQ (TYPEP PKG) 'PACKAGE) PKG (PKG-FIND-PACKAGE "USER")))
      (*CATCH 'SI:TOP-LEVEL
	      (*CATCH 'QUIT
		      (PROGN
			(FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
			(MULTIPLE-VALUE (SPECIAL-CHAR SEXP)
			  (WINDOW-COMMAND-LOOP-READ T))
			(IF SPECIAL-CHAR
			    (PROCESS-SPECIAL-COMMAND SPECIAL-CHAR ERROR-SG ETE)
			    (LET ((RESULTS (SG-EVAL ERROR-SG (SETQ - SEXP) T)))
			      (SETQ + -)
			      (COND ((NEQ RESULTS ERROR-FLAG)
				     (SETQ * (CAR RESULTS))
				     (MAPC 'PRINT RESULTS)))))))))))

(DEFUN PROCESS-SPECIAL-COMMAND (LIST SG ETE &AUX OPERATION VALUE WINDOW)
  (SETQ OPERATION (FIRST LIST)
	VALUE (SECOND LIST)
	WINDOW (THIRD LIST))
  (AND (FUNCALL ERROR-HANDLER-WINDOW ':INSPECT-WINDOW-P WINDOW)
       (IF (= (FOURTH LIST) #\MOUSE-1-1)
	   (SETQ OPERATION ':INSPECT)
	   (SETQ OPERATION ':VALUE
		 VALUE (TV:INSPECT-REAL-VALUE LIST))))
  (COND ((AND (EQ OPERATION ':MENU) (MEMQ (SETQ VALUE (CDR VALUE)) '(T NIL-VALUE)))
	 (FUNCALL STANDARD-OUTPUT ':LINE-OUT (IF (SETQ VALUE (EQ VALUE T)) "T" "()"))
	 (SETQ OPERATION ':VALUE + VALUE)))
  (COND ((EQ OPERATION ':LINE-AREA)
	 (SETQ CURRENT-FRAME VALUE)
	 (FUNCALL ERROR-HANDLER-WINDOW ':SETUP-FRAME SG CURRENT-FRAME))
	((EQ OPERATION ':MENU)
	 (FUNCALL VALUE SG ETE))			;Execute a regular menu command
	((EQ OPERATION ':INSPECT)
	 (FUNCALL ERROR-HANDLER-WINDOW ':INSPECT-OBJECT (TV:INSPECT-REAL-VALUE LIST)))
	((MEMQ OPERATION '(:VALUE :FUNCTION STACK-FRAME SPECIAL ARG LOCAL))
	 (COND ((MEMQ OPERATION '(SPECIAL ARG LOCAL))
		(COND ((MEMQ OPERATION '(ARG LOCAL))
		       (PRIN1 (FIRST VALUE))
		       (LET ((IDX (SECOND VALUE)))
			 (IF (NOT (NUMBERP IDX))
			     (AND (EQUAL IDX "Rest arg")
				  (SETQ VALUE (SG-REST-ARG-VALUE SG CURRENT-FRAME)))
			     (LET ((RP (SG-REGULAR-PDL SG)))
			       (SETQ + (ALOC RP
					     (+ CURRENT-FRAME IDX
						(IF (EQ OPERATION 'ARG) 1
						    (RP-LOCAL-BLOCK-ORIGIN
						      RP CURRENT-FRAME))))))
			     (SETQ VALUE (CAR +)))))
		      (T
		       (SETQ + (PRIN1 VALUE))
		       (SETQ VALUE (SYMEVAL VALUE))))
		(TERPRI))
	       ((EQ OPERATION 'STACK-FRAME)
		(SETQ VALUE (STACK-FRAME-INTO-LIST VALUE SG))))
	 (SETQ * (PRIN1 VALUE)))
	(T
	 (TV:BEEP))))

;;;This reads a form or special command (a list in the input stream)
(DEFUN WINDOW-COMMAND-LOOP-READ (&OPTIONAL PREEMPTABLE)
  (DO ((CHAR -1) (SEXP) (FLAG) (TYPEAHEAD)) (NIL)
    (UNWIND-PROTECT
      (PROGN
	(COND ((NOT PREEMPTABLE)
	       (SETQ TYPEAHEAD (FUNCALL TERMINAL-IO ':OLD-TYPEAHEAD))
	       (FUNCALL TERMINAL-IO ':SET-OLD-TYPEAHEAD NIL)))
	(OR (FUNCALL TERMINAL-IO ':OLD-TYPEAHEAD)
	    (SETQ CHAR (FUNCALL TERMINAL-IO ':ANY-TYI)))
	(COND ((LISTP CHAR) (RETURN CHAR))
	      ((= CHAR #\FORM) (FUNCALL TERMINAL-IO ':CLEAR-SCREEN))
	      ((= CHAR #\RUBOUT))
	      (T
	       (AND ( CHAR 0) (FUNCALL TERMINAL-IO ':UNTYI CHAR))
	       (MULTIPLE-VALUE (SEXP FLAG)
		 (FUNCALL TERMINAL-IO ':PREEMPTABLE-READ
			  '((:FULL-RUBOUT :FULL-RUBOUT)) #'SI:READ-FOR-TOP-LEVEL))
	       (AND (EQ FLAG ':MOUSE-CHAR) (RETURN SEXP))
	       (OR (EQ FLAG ':FULL-RUBOUT) (RETURN NIL SEXP)))))
      (OR PREEMPTABLE
	  (FUNCALL TERMINAL-IO ':SET-OLD-TYPEAHEAD TYPEAHEAD)))))

;;;This gets an object to return or something
(DEFUN WINDOW-READ-OBJECT (PROMPT &AUX SPECIAL SEXP ASK-P)
  (UNWIND-PROTECT
    (PROG ()
	(FUNCALL ERROR-HANDLER-WINDOW ':SET-SENSITIVE-ITEM-TYPES
		 '(:VALUE :FUNCTION STACK-FRAME))
       RETRY
	(FORMAT T "~A~%" PROMPT)
	(MULTIPLE-VALUE (SPECIAL SEXP)
	   (WINDOW-COMMAND-LOOP-READ))
	(COND ((LISTP SPECIAL)
	       (IF (FUNCALL ERROR-HANDLER-WINDOW ':INSPECT-WINDOW-P (THIRD SPECIAL))
		   (SETQ SEXP (TV:INSPECT-REAL-VALUE SPECIAL) ASK-P T)
		   (LET ((TYPE (FIRST SPECIAL)))
		     (COND ((EQ TYPE ':VALUE)
			    (SETQ SEXP (SECOND SPECIAL) ASK-P T))
			   ((AND (EQ TYPE ':MENU)
				 (MEMQ (CDR (SECOND SPECIAL)) '(T NIL-VALUE)))
			    (SETQ SEXP (EQ (CDR (SECOND SPECIAL)) T) ASK-P NIL))
			   (T
			    (TV:BEEP)
			    (GO RETRY))))))
	      (T
	       (SETQ ASK-P (CONSTANT-FORM-P SEXP)
		     SEXP (CAR (SG-EVAL ERROR-SG SEXP)))))
	(AND ASK-P (COND ((NOT (WINDOW-Y-OR-N-P "The object is ~S, ok? " SEXP))
			  (TERPRI)
			  (GO RETRY))))
	(RETURN SEXP))
    (FUNCALL ERROR-HANDLER-WINDOW ':SET-SENSITIVE-ITEM-TYPES T)))

(DEFUN WINDOW-Y-OR-N-P (STRING &REST FORMAT-ARGS)
  (LEXPR-FUNCALL #'FORMAT T STRING FORMAT-ARGS)
  (DO ((CH)) (NIL)
    (SETQ CH (FUNCALL STANDARD-INPUT ':ANY-TYI))
    (AND (LISTP CH) (EQ (FIRST CH) ':MENU) (MEMQ (CDR (SECOND CH)) '(T NIL-VALUE))
	 (SETQ CH (IF (EQ (CDR (SECOND CH)) T) #/Y #/N)))
    (COND ((MEMQ CH '(#/Y #/y #\SP))
	   (PRINC "yes")
	   (RETURN T)))
    (COND ((MEMQ CH '(#/N #/n #\RUBOUT))
	   (PRINC "no")
	   (RETURN NIL)))
    (PRINC "(Y or N)")))

(DEFUN WINDOW-READ-FUNCTION (ACTION &OPTIONAL ALLOW-T RETURN-STACK-FRAMES
				    &AUX SPECIAL FUNCTION)
  (FORMAT T "~&Type or mouse a function ~A, or mouse NIL to abort~:[, or T for nothing~]:~%"
	  ACTION (NOT ALLOW-T))
  (MULTIPLE-VALUE (SPECIAL FUNCTION)
    (WINDOW-COMMAND-LOOP-READ))
  (AND SPECIAL
       (SETQ FUNCTION
	     (SELECTQ (FIRST SPECIAL)
	       (:MENU (AND (EQ (CDR (SECOND SPECIAL)) T) ALLOW-T))
	       (STACK-FRAME (IF RETURN-STACK-FRAMES SPECIAL
				(STACK-FRAME-FUNCTION-AND-ARGS ERROR-SG (SECOND SPECIAL))))
	       (:LINE-AREA (IF RETURN-STACK-FRAMES (LIST 'STACK-FRAME (SECOND SPECIAL))
			       (STACK-FRAME-FUNCTION-AND-ARGS ERROR-SG (SECOND SPECIAL))))
	       ((SPECIAL ARG LOCAL) (FIRST (SECOND SPECIAL)))
	       ((:VALUE :FUNCTION SPECIAL) (SECOND SPECIAL)))))
  (AND (CLOSUREP FUNCTION) (SETQ FUNCTION (CAR (%MAKE-POINTER DTP-LIST FUNCTION))))
  (COND ((MEMQ (DATA-TYPE FUNCTION) '(DTP-ENTITY DTP-INSTANCE DTP-SELECT-METHOD))
	 (SETQ SPECIAL (WINDOW-READ-THING "~&Type or mouse a message name for ~S:~%"
					  FUNCTION))
	 (LET ((HANDLER (GET-HANDLER-FOR FUNCTION SPECIAL)))
	   (OR HANDLER (FORMAT T "~&~S does not handle the ~S message.~%" FUNCTION SPECIAL))
	   (SETQ FUNCTION HANDLER)))
	((NULL FUNCTION)
	 (FORMAT T "~&Aborted.~%")))
  FUNCTION)

(DEFUN WINDOW-READ-THING (PROMPT &REST FORMAT-ARGS &AUX SPECIAL THING)
  (LEXPR-FUNCALL #'FORMAT T PROMPT FORMAT-ARGS)
  (MULTIPLE-VALUE (SPECIAL THING)
    (WINDOW-COMMAND-LOOP-READ))
  (IF SPECIAL
      (IF (FUNCALL ERROR-HANDLER-WINDOW ':INSPECT-WINDOW-P (THIRD SPECIAL))
	  (TV:INSPECT-REAL-VALUE SPECIAL)
	  (SELECTQ (FIRST SPECIAL)
	    (:MENU (EQ (CDR (SECOND SPECIAL)) T))
	    ((SPECIAL ARG LOCAL) (FIRST (SECOND SPECIAL)))
	    ((:VALUE :FUNCTION SPECIAL) (SECOND SPECIAL))))
      (CAR (SG-EVAL ERROR-SG THING))))

;;;The commands
(DEFUN COMW-WHAT-ERROR (SG ETE)
  (PRINT-ERROR-MESSAGE SG ETE T))

(DEFUN COMW-SEARCH (SG IGNORE &AUX KEY AP)
  (FORMAT T "String to search for (end with RETURN):~%")
  (SETQ KEY (READLINE))
  (SETQ AP (DO ((AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG AP))
		(RP (SG-REGULAR-PDL SG))
		(NAME))
	       ((NULL AP) NIL)
	     (SETQ NAME (FUNCTION-NAME (RP-FUNCTION-WORD RP AP)))
	     (SETQ NAME (COND ((STRINGP NAME) NAME)
			      ((SYMBOLP NAME) (STRING NAME))
			      (T (FORMAT NIL "~S" NAME))))
	     (AND (STRING-SEARCH KEY NAME) (RETURN AP))))
  (COND ((NULL AP)
	 (FORMAT T "Search failed.~%"))
	(T
	 (SETQ CURRENT-FRAME AP)
	 (FUNCALL ERROR-HANDLER-WINDOW ':SETUP-FRAME SG CURRENT-FRAME))))

(COMMENT
(DEFUN COM-PRINT-SPECIALS (SG IGNORE &AUX START END)
  (MULTIPLE-VALUE (START END)
    (SG-FRAME-SPECIAL-PDL-RANGE SG CURRENT-FRAME))
  (IF START
      (PRINT-SPECIAL-PDL-RANGE SG START END)
      (PRINC "This frame has no special variable bindings.")))
)

(DEFUN COMW-DESCRIBE (IGNORE IGNORE &AUX THING)
  (AND (SETQ THING (WINDOW-READ-THING "~&Type or mouse something to describe:~%"))
       (DESCRIBE THING)))				;This should go to a typeout stream

(DEFUN COMW-INSPECT (IGNORE IGNORE &AUX THING)
  (AND (SETQ THING (WINDOW-READ-THING "~&Type or mouse something to inspect:~%"))
       (FUNCALL ERROR-HANDLER-WINDOW ':INSPECT-OBJECT THING)))

(DEFUN COMW-ARGLIST (SG IGNORE &AUX FUNCTION)
  (AND (SETQ FUNCTION (WINDOW-READ-FUNCTION "for arglist" NIL T))
       (COND ((AND (SYMBOLP FUNCTION) (NOT (FBOUNDP FUNCTION)))
	      (FORMAT T "~&~S is not defined." FUNCTION))
	     ((AND (LISTP FUNCTION) (EQ (FIRST FUNCTION) 'STACK-FRAME))
	      (PRINT-FRAME-ARGLIST SG (SECOND FUNCTION)))
	     (T
	      (SETQ FUNCTION (FUNCTION-NAME FUNCTION))
	      (FORMAT T "~&~S: ~:A~%" FUNCTION (ARGLIST FUNCTION))))))

(DEFUN PRINT-FRAME-ARGLIST (SG AP &AUX STR1 STR2 FUNCTION ARGS-START ARGS-END)
  (SETQ STR1 (MAKE-ARRAY NIL 'ART-STRING 50. NIL '(0))
	STR2 (MAKE-ARRAY NIL 'ART-STRING 50. NIL '(0)))
  (ARRAY-PUSH-EXTEND STR1 (SI:PTTBL-OPEN-PAREN READTABLE))
  (MULTIPLE-VALUE (FUNCTION ARGS-START ARGS-END) (STACK-FRAME-FUNCTION-AND-ARGS SG AP))
  (LET ((FORMAT:FORMAT-STRING STR1))
    (PRIN1 (FUNCTION-NAME FUNCTION) 'FORMAT:FORMAT-STRING-STREAM))
  (ARRAY-PUSH-EXTEND STR1 (SI:PTTBL-SPACE READTABLE))
  (COPY-ARRAY-CONTENTS-AND-LEADER STR1 STR2)
  (DO ((ARGLIST (ARGLIST FUNCTION) (CDR ARGLIST))
       (RP (SG-REGULAR-PDL SG))
       (I ARGS-START)
       (FLAG NIL T))
      ((AND (NULL ARGLIST) ( I ARGS-END)))
    (LET ((I1 (IF FLAG 1 0)) (I2 (IF FLAG 1 0)))
      (LET ((LEN1 (ARRAY-LEADER STR1 0))
	    (LEN2 (ARRAY-LEADER STR2 0)))
	(COND ((> LEN1 LEN2)
	       (SETQ I2 (1+ (- LEN1 LEN2))))
	      ((< LEN1 LEN2)
	       (SETQ I1 (1+ (- LEN2 LEN1))))))
      (COND (ARGLIST
	      (DOTIMES (I I1) (ARRAY-PUSH-EXTEND STR1 #\SP))
	      (LET ((FORMAT:FORMAT-STRING STR1))
		(PRIN1 (CAR ARGLIST) 'FORMAT:FORMAT-STRING-STREAM))
	      (AND (MEMQ (CAR ARGLIST) '(&OPTIONAL &REST))
		   (SETQ FLAG '&MUMBLE))))
      (COND ((< I ARGS-END)
	      (DOTIMES (I I2) (ARRAY-PUSH-EXTEND STR2 #\SP))
	      (COND ((NEQ FLAG '&MUMBLE)
		     (LET ((FORMAT:FORMAT-STRING STR2))
		       (PRIN1 (AREF RP I) 'FORMAT:FORMAT-STRING-STREAM))
		     (SETQ I (1+ I))))))))
  (ARRAY-PUSH-EXTEND STR2 (SI:PTTBL-CLOSE-PAREN READTABLE))
  (ARRAY-PUSH-EXTEND STR1 (SI:PTTBL-CLOSE-PAREN READTABLE))
  (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
  (FUNCALL STANDARD-OUTPUT ':LINE-OUT STR1)
  (FUNCALL STANDARD-OUTPUT ':LINE-OUT STR2))

(DEFUN STACK-FRAME-INTO-LIST (AP SG &AUX LIST FUNCTION ARGS-START ARGS-END)
  (MULTIPLE-VALUE (FUNCTION ARGS-START ARGS-END) (STACK-FRAME-FUNCTION-AND-ARGS SG AP))
  (SETQ LIST (NCONS (FUNCTION-NAME FUNCTION)))
  (DO ((I ARGS-START (1+ I))
       (RP (SG-REGULAR-PDL SG)))
      (( I ARGS-END))
    (PUSH (AREF RP I) LIST))
  (NREVERSE LIST))

(DEFUN COMW-EDIT (IGNORE IGNORE &AUX THING)
  (AND (SETQ THING (WINDOW-READ-FUNCTION "to edit" T))
       (PRIN1 (ZED (IF (EQ THING T) NIL (FUNCTION-NAME THING))))))

(DEFUN COMW-SET-ARG (SG IGNORE &AUX CHAR)
  (FORMAT T "~&Mouse an argument or local to modify:~%")
  (SETQ CHAR (FUNCALL STANDARD-INPUT ':ANY-TYI))
  (IF (NOT (AND (LISTP CHAR) (MEMQ (CAR CHAR) '(LOCAL ARG))))
      (FORMAT T "~&That is not an argument or local~%")
      (LET ((IDX (CADADR CHAR)))
	(IF (NOT (NUMBERP IDX))
	    (FORMAT T "~&Cannot set rest arg")
	    (LET ((NEW-OBJ (READ-OBJECT (FORMAT NIL "Value to substitute for ~A:"
						(CAADR CHAR)))))
	      (LET ((RP (SG-REGULAR-PDL SG)))
		(ASET NEW-OBJ RP
		      (+ CURRENT-FRAME IDX (IF (EQ (CAR CHAR) 'ARG) 1
					       (RP-LOCAL-BLOCK-ORIGIN RP CURRENT-FRAME))))))))
      (FUNCALL ERROR-HANDLER-WINDOW ':SETUP-FRAME SG CURRENT-FRAME T)))