head	1.14;
access;
symbols
	new_struct:1.11.1;
locks; strict;


1.14
date	94.10.31.04.11.27;	author ram;	state Exp;
branches;
next	1.13;

1.13
date	93.06.10.03.10.43;	author wlott;	state Exp;
branches;
next	1.12;

1.12
date	93.02.26.08.25.39;	author ram;	state Exp;
branches;
next	1.11;

1.11
date	92.07.16.18.57.10;	author ram;	state Exp;
branches
	1.11.1.1;
next	1.10;

1.10
date	92.02.24.01.29.10;	author wlott;	state Exp;
branches;
next	1.9;

1.9
date	91.10.22.16.17.37;	author ram;	state Exp;
branches;
next	1.8;

1.8
date	91.08.30.17.33.57;	author ram;	state Exp;
branches;
next	1.7;

1.7
date	91.05.21.18.35.16;	author ram;	state Exp;
branches;
next	1.6;

1.6
date	91.05.15.16.29.38;	author ram;	state Exp;
branches;
next	1.5;

1.5
date	91.02.14.18.46.15;	author ram;	state Exp;
branches;
next	1.4;

1.4
date	91.02.08.13.33.13;	author ram;	state Exp;
branches;
next	1.3;

1.3
date	90.02.22.12.00.38;	author ram;	state Exp;
branches;
next	1.2;

1.2
date	90.02.12.11.55.08;	author ram;	state Exp;
branches;
next	1.1;

1.1
date	90.02.06.17.24.38;	author ram;	state Exp;
branches;
next	;

1.11.1.1
date	93.01.15.15.27.58;	author ram;	state Exp;
branches;
next	1.11.1.2;

1.11.1.2
date	93.01.23.14.22.24;	author ram;	state Exp;
branches;
next	;


desc
@@


1.14
log
@Fix headed boilerplate.
@
text
@;;; -*- Mode: Lisp; Package: INSPECT; Log:code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: $")
;;;
;;; **********************************************************************
;;;
;;; An inspector for CMU Common Lisp.
;;; 
;;; Written by Skef Wholey.
;;; Ported to CLX by Christopher Hoover with minor tweaks by Bill Chiles.
;;;
;;; Each Lisp object is displayed in its own X window, and components of
;;; each object are "mouse sensitive" items that may be selected for
;;; further investigation.  This is all done with a kind of home-made object
;;; system, based on Defstruct.
;;;
;;; NOTE: due to porting this code between X10 and X11, there is a gross
;;; confusion in the code based on the term "display".  Sometimes it means a
;;; CLX display structure, and sometimes it means a disp structure defined in
;;; this file.  This disp structure also uses the conc-name "display-".
;;; AN ATTEMPT TO CORRECT THIS HAS BEEN MADE BY RENAMING SUCH THINGS TO
;;; DISPLAY-INFO, BUT PROBLEMS STILL EXIST.  There is a DISPLAY-ITEM-DISPLAY
;;; which is neither a CLX display or the display of an object; it is a method
;;; which displays the item.
;;;

(in-package "LISP")
(export 'inspect)

(in-package "INSPECT" :use '("LISP" "KERNEL" "EXTENSIONS"))
(export '(show-object remove-object-display remove-all-displays
		      *interface-style*))


;;; Parameters and stuff.

;;; CLX specials

(defvar *display* nil)
(defvar *screen* nil)
(defvar *root* nil)
(defvar *gcontext* nil)
(defvar *black-pixel* nil)
(defvar *white-pixel* nil)

;;; Inspect-Length is the number of components that will be displayed in a
;;; window at any one time.  If an object has more than Inspect-Length 
;;; components, we generally put it in a scrolling window.  Inspect-Level
;;; might someday correspond to Print-Level, controlling the amount of
;;; detail and mouse-sensitivity we get inside components, but for now
;;; it's ignored.

(defparameter inspect-length 10)
(defparameter inspect-level 1)


;;; Inspect-Print-Level and Inspect-Print-Length are used by IPrin1-To-String
;;; to generate the textual representation of components.

(defparameter inspect-print-length 10)
(defparameter inspect-print-level 3)

(defun iprin1-to-string (object)
  (let ((*print-length* inspect-print-length)
	(*print-level* inspect-print-level)
	(*print-pretty* nil))
    (prin1-to-string object)))


;;; Inspect-Line-Length is a hack used in only one place that we should get
;;; rid of someday.

(defparameter inspect-line-length 80)


;;; Setting up fonts and cursors and stuff.

;;; We use Font structures to keep stuff like the character height and width
;;; of a font around for quick and easy size calculations.  For variable width
;;; fonts, the Width slot will be Nil.

(defstruct (font (:constructor make-font (name font height ascent width)))
  name
  font
  height
  ascent
  width)


;;; The *Header-Font* is a big font usually used for displaying stuff in
;;; the header portion of an object display.  *Entry-Font* is used as the
;;; main "body font" for an object, and *Italic-Font* is used for special
;;; stuff.


(defparameter header-font-name "*-courier-bold-r-normal--*-120-*")
(defvar *header-font*)

(defparameter entry-font-name "*-courier-medium-r-normal--*-120-*")
(defvar *entry-font*)

(defparameter italic-font-name "*-courier-medium-o-normal--*-120-*")
(defvar *italic-font*)

;;; The *Cursor* is a normal arrow thing used most of the time.  During
;;; modification operations, we change the cursor to *Cursor-D* (while the
;;; destination for the modification is being chosen) and *Cursor-S* (while
;;; the source is being chosen).

(defparameter cursor-name "library:inspect11.cursor")
(defvar *cursor*)
(defparameter cursor-d-name "library:inspect11-d.cursor")
(defvar *cursor-d*)
(defparameter cursor-s-name "library:inspect11-s.cursor")
(defvar *cursor-s*)


;;; This file contains the help message for the inspector.  The text in the
;;; file must not extend past the 72nd column, and any initial whitespace on
;;; a line must be built on the space character only.  The window that displays
;;; this text is too small in height for easy reading of this text.
;;;
(defparameter help-file-pathname "library:inspector.help")



;;;; CLX stuff

;;; The arrow bitmaps are used inside scrollbars.

(defvar *up-arrow*)
(defvar *down-arrow*)
(defvar *up-arrow-i*)
(defvar *down-arrow-i*)

(defparameter arrow-bits
  '(#*0000000000000000
    #*0111111111111110
    #*0100000000000010
    #*0100000110000010
    #*0100001111000010
    #*0100011111100010
    #*0100111111110010
    #*0101111111111010
    #*0100001111000010
    #*0100001111000010
    #*0100001111000010
    #*0100001111000010
    #*0100001111000010
    #*0100000000000010
    #*0111111111111110
    #*0000000000000000))


;;; Font and cursor support

(defun open-font (name)
  (let* ((font (xlib:open-font *display* name))
	 (max-width (xlib:max-char-width font))
	 (min-width (xlib:min-char-width font))
	 (width (if (= max-width min-width) max-width nil))
	 (ascent (xlib:max-char-ascent font))
	 (height (+ (xlib:max-char-descent font) ascent)))
    (make-font name font height ascent width)))

(defun get-cursor-pixmap-from-file (name)
  (let ((pathname (probe-file name)))
    (if pathname
	(let* ((image (xlib:read-bitmap-file pathname))
	       (pixmap (xlib:create-pixmap :width 16 :height 16
					   :depth 1 :drawable *root*))
	       (gc (xlib:create-gcontext :drawable pixmap
					 :function boole-1
					 :foreground *black-pixel*
					 :background *white-pixel*)))
	  (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
	  (xlib:free-gcontext gc)
	  (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image)))
	(values nil nil nil))))

(defun open-cursor (name)
  (multiple-value-bind
      (cursor-pixmap cursor-x-hot cursor-y-hot)
      (get-cursor-pixmap-from-file name)
    (multiple-value-bind
	(mask-pixmap mask-x-hot mask-y-hot)
	(get-cursor-pixmap-from-file (make-pathname :type "mask" :defaults name))
      (declare (ignore mask-x-hot mask-y-hot))
      (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
	     (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
	     (cursor (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
					 :x cursor-x-hot :y cursor-y-hot
					 :foreground black :background white)))
	(xlib:free-pixmap mask-pixmap)
	(xlib:free-pixmap cursor-pixmap)
	cursor))))

(defun bitvec-list-to-pixmap (bvl width height)
  (let* ((image (apply #'xlib:bitmap-image bvl))
	 (pixmap (xlib:create-pixmap :width width :height height
				     :drawable *root*
				     :depth (xlib:screen-root-depth *screen*)))
	 (gc (xlib:create-gcontext :drawable pixmap
				   :function boole-1
				   :foreground *black-pixel*
				   :background *white-pixel*)))
    (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16 :bitmap-p t)
    (xlib:free-gcontext gc)
    pixmap))

(defun invert-pixmap (pixmap)
  (let* ((width (xlib:drawable-width pixmap))
	 (height (xlib:drawable-height pixmap))
	 (inv-pixmap (xlib:create-pixmap :width width :height height
					 :drawable *root*
					 :depth (xlib:screen-root-depth *screen*)))
	 (gc (xlib:create-gcontext :drawable inv-pixmap
				   :function boole-c1
				   :foreground *black-pixel*
				   :background *white-pixel*)))
    (xlib:copy-area pixmap gc 0 0 width height inv-pixmap 0 0)
    (xlib:free-gcontext gc)
    inv-pixmap))


;;;; Inspect-Init

;;; Inspect-Init sets all this stuff up, using *Inspect-Initialized* to
;;; know when it's already been done.

(defvar *inspect-initialized* nil)

(defun inspect-init ()
  (unless *inspect-initialized*
    (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
    (ext:carefully-add-font-paths
     *display*
     (mapcar #'(lambda (x)
		 (concatenate 'string (namestring x) "fonts/"))
	     (search-list "library:")))
    (setq *root* (xlib:screen-root *screen*))
    (setq *black-pixel* (xlib:screen-black-pixel *screen*))
    (setq *white-pixel* (xlib:screen-white-pixel *screen*))
    (setq *gcontext* (xlib:create-gcontext :drawable *root* :function boole-1
					   :foreground *black-pixel*
					   :background *white-pixel*))
    (setq *cursor* (open-cursor cursor-name))
    (setq *cursor-d* (open-cursor cursor-d-name))
    (setq *cursor-s* (open-cursor cursor-s-name))
    (setq *header-font* (open-font header-font-name))
    (setq *entry-font* (open-font entry-font-name))
    (setq *italic-font* (open-font italic-font-name))
    (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16))
    (setq *up-arrow-i* (invert-pixmap *up-arrow*))
    (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16))
    (setq *down-arrow-i* (invert-pixmap *down-arrow*))
    (ext:enable-clx-event-handling *display* 'inspector-event-handler)
    (setq *inspect-initialized* t)))

#|
;;; For debugging...
;;; 
(defun inspect-reinit (&optional (host "unix:0.0"))
  (let ((win nil))
    (setq *inspect-initialized* nil)
    (when *display*
      (ext:disable-clx-event-handling *display*)
      (xlib:close-display *display*)))
    (unwind-protect
	(progn
	  (multiple-value-setq
	      (*display* *screen*)
	    (ext:open-clx-display host))
	  (setf (xlib:display-after-function *display*)
		#'xlib:display-finish-output)
	  (setq *root* (xlib:screen-root *screen*))
	  (setq *black-pixel* (xlib:screen-black-pixel *screen*))
	  (setq *white-pixel* (xlib:screen-white-pixel *screen*))
	  (setq *gcontext* (xlib:create-gcontext :drawable *root*
						 :function boole-1
						 :foreground *black-pixel*
						 :background *white-pixel*))
	  (setq *cursor* (open-cursor cursor-name))
	  (setq *cursor-d* (open-cursor cursor-d-name))
	  (setq *cursor-s* (open-cursor cursor-s-name))
	  (setq *header-font* (open-font header-font-name))
	  (setq *entry-font* (open-font entry-font-name))
	  (setq *italic-font* (open-font italic-font-name))
	  (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16))
	  (setq *up-arrow-i* (invert-pixmap *up-arrow*))
	  (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16))
	  (setq *down-arrow-i* (invert-pixmap *down-arrow*))
	  (setf (xlib:display-after-function *display*) nil)
	  (setf win t))
      (cond (win
	     (ext:enable-clx-event-handling *display* 'inspector-event-handler)
	     (setq *inspect-initialized* t))
	    (*display*
	     (xlib:close-display *display*))))))
|#


;;; More X Stuff

;;; We use display-info structures to associate objects with their graphical
;;; images (Display-Items, see below), the X windows that they're displayed in,
;;; and maybe even a user-supplied Name for the whole thing.

(defstruct (display-info
	    (:constructor make-display-info (name object display-item window)))
  name
  object
  display-item
  window
  (stack nil))

;;; *display-infos* is a list of all the live displays of objects.
;;;
(defvar *display-infos* nil)


;;; CLX window to display-info structure mapping.
;;;
(defvar *windows-to-displays* (make-hash-table :test #'eq))

(defun add-window-display-info-mapping (window display-info)
  (setf (gethash window *windows-to-displays*) display-info))

(defun delete-window-display-info-mapping (window)
  (remhash window *windows-to-displays*))

(defun map-window-to-display-info (window)
  (multiple-value-bind (display-info found-p)
		       (gethash window *windows-to-displays*)
    (unless found-p (error "No such window as ~S in mapping!" window))
    display-info))



;;; *Tracking-Mode* is a kind of hack used so things know what to do
;;; during modify operations.  If it's :Source, only objects that are really
;;; there will be selectable.  If it's :Destination, objects that aren't
;;; necessarily really there (like the values of unbound symbols) will be
;;; selectable.

(defvar *tracking-mode* :source)


;;; *Mouse-X* and *Mouse-Y* are a good approximation of where the mouse is
;;; in the window that the mouse is in.

(defvar *mouse-x* 0)
(defvar *mouse-y* 0)


;;;; Event Handling

;;; We're interested in these events:

(eval-when (compile load eval)
  (defconstant important-xevents
    '(:key-press :button-press :exposure :pointer-motion
		 :enter-window :leave-window))
  
  (defconstant important-xevents-mask
    (apply #'xlib:make-event-mask important-xevents)))


(defun inspector-event-handler (display)
  (xlib:event-case (display :discard-p t :force-output-p t :timeout 0)
    ((:exposure) (event-window count)
     (when (zerop count)
       (redisplay-item
	(display-info-display-item (map-window-to-display-info event-window))))
     t)
    ((:key-press) (event-window state code)
     (do-command (map-window-to-display-info event-window)
		 (ext:translate-key-event display code state))
     t)
    ((:button-press :button-release) (event-key event-window state code)
     (do-command (map-window-to-display-info event-window)
		 (ext:translate-mouse-key-event code state event-key))
     t)
    ((:enter-notify :motion-notify) (event-window x y)
     (cond ((xlib:event-listen display)
	    ;; if there are other things in the queue, blow this event off...
	    nil)
	   (t
	    (setf *mouse-x* x)
	    (setf *mouse-y* y)
	    (track-mouse (display-info-display-item
			  (map-window-to-display-info event-window))
			 x y)
	    t)))
    ((:leave-notify) (event-window)
     (track-mouse (display-info-display-item
		   (map-window-to-display-info event-window))
		  -1 -1)
     t)
    ((:no-exposure) ()
     ;; just ignore this one
     t)
    (t (event-key)
       (warn "Inspector received unexpected event, ~S, recieved." event-key)
       t)))

#|

;;; Some debugging code...

    (xlib:event-cond (display :timeout 0 :peek-p t)
		     (t (event-key)
			(unless (eq event-key :motion-notify)
			  (format t "Event received: ~S~%" event-key))))

(defun discard-event-on-window (display window type)
  (loop
    (unless (xlib:process-event display :timeout 0
	      :handler #'(lambda (&key event-window event-type &allow-other-keys)
			   (and (eq event-window window)
				(eq event-type type))))
      (return))))

|#
    

;;;; Yet more X stuff.

;;; NEXT-WINDOW-POSITION currently uses a very dumb heuristic to decide where
;;; the next inspector window ought to go.  If there aren't any windows, it
;;; puts the display of an object in the upper left hand corner.  Otherwise,
;;; it'll put it underneath the last one created.  When putting the new
;;; window below the last one, if it should extent below the bottom of the
;;; screen, we position it to just fit on the bottom.  Thus, all future windows
;;; created in this fashion will "pile up" on the bottom of the screen.
;;;
(defun next-window-position (width height)
  (declare (ignore width))
  (if *display-infos*
      (let ((window (display-info-window (car *display-infos*))))
	(xlib:with-state (window)
	  (let ((drawable-x (xlib:drawable-x window))
		(drawable-y (xlib:drawable-y window))
		(drawable-height (xlib:drawable-height window))
		(border-width (xlib:drawable-border-width window)))
	    (declare (fixnum drawable-y drawable-height border-width))
	    (multiple-value-bind (children parent root) (xlib:query-tree window)
	      (declare (ignore children))
	      (let ((root-height (xlib:drawable-height root)))
		(declare (fixnum root-height))
		(multiple-value-bind
		    (new-x new-y)
		    (if (eq parent root)
			(values drawable-x (+ drawable-y drawable-height
					      (* 2 border-width)))
			;; Deal with reparented windows...
			(multiple-value-bind (root-x root-y)
					     (xlib:translate-coordinates
					      parent drawable-x drawable-y root)
			  (declare (fixnum root-y))
			  (values root-x (+ root-y drawable-height
					    (* 2 border-width)))))
		  (declare (fixnum new-y))
		  (values new-x
			  (if (> (+ new-y height border-width) root-height)
			      (- root-height height border-width)
			      new-y))))))))
      (values 2 2)))

;;; Max-Window-Width is used to constrain the width of our displays.

(defparameter max-window-width 700)


;;; Border is the number of pixels between an object display and the box
;;; we draw around it.  VSP is the number of pixels we leave between lines
;;; of text.  (We should put VSP in the fonts structure sometime so we can
;;; have font-specific vertical spacing.)

(defparameter border 3)
(defparameter vsp 2)


;;; *X-Constraint* is used by Disp-String to truncate long strings so that
;;; they stay inside windows of reasonable width.

(defvar *x-constraint* nil)


;;; Disp-String draws a string, trying to constrain it to not run beyond the
;;; *X-Constraint*.  For variable width fonts, we can only guess about the
;;; right length...

(defun disp-string (window x y string disp-font)
  (declare (simple-string string))
  (let ((font (font-font disp-font))
	(font-width (font-width disp-font))
	(font-height (font-height disp-font))
	(length (length string))
	(max-width (if *x-constraint* (- *x-constraint* x) max-window-width)))
    (cond (font-width
	   ;; fixed width font
	   (let ((end (if (<= (* length font-width) max-width)
			  length
			  (max 0 (truncate max-width font-width)))))
	     (when window
	       (xlib:with-gcontext (*gcontext* :font font)
		 (xlib:draw-image-glyphs window *gcontext*
					 x (+ y (font-ascent disp-font))
					 string :end end)))
	     (values (* end font-width) (+ font-height vsp))))
	  (t
	   ;; this is hackish...
	   (multiple-value-bind
	       (end width)
	       (do* ((index length (1- index))
		     (width (xlib:text-width font string :end index)
			    (xlib:text-width font string :end index)))
		    ((or (= index 0) (<= width max-width))
		     (values index width)))
	     (when window
	       (xlib:with-gcontext (*gcontext* :font font)
		 (xlib:draw-image-glyphs window *gcontext*
					 x (+ y (font-ascent disp-font))
					 string :end end)))
	     (values width (+ font-height vsp)))))))


;;;; Draw-Bitmap, Draw-Box, and Draw-Block

(defun draw-bitmap (window x y pixmap)
  (xlib:copy-area pixmap *gcontext* 0 0 16 16 window x y))

(defun draw-box (window x1 y1 x2 y2)
  (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1)))

(defun draw-block (window x1 y1 x2 y2)
  (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1) t))


;;;; Display-Item

;;; Display-Items are objects with methods to display themselves, track the
;;; mouse inside their boundries, handle mouse clicks on themselves, and so
;;; on.  Everything we put up on the screen is backed in some way by a
;;; Display-Item.  These are the components of the total display of an object
;;; as described in a display-info structure.
;;;
(defstruct (display-item
	    (:print-function print-display-item))
  display			; Takes self, window, x, y
  (tracker 'nothing-tracker)	; Takes self, x, y
  (untracker 'nothing-untracker); Takes self
  (mouse-handler 'nothing-mouse-handler) ; Takes self, display, key-event
  (walker 'nothing-walker)	; Takes self, function to walk
  window			; Window and position and size once displayed
  x
  y
  width
  height
  )

(defun print-display-item (item stream depth)
  (declare (ignore depth))
  (format stream "#<~S {~8,'0X}>" (type-of item)
	  #+cmu
	  (kernel:get-lisp-obj-address item)
	  #-cmu 0))

;;; The *Current-Item* is the display item that is currently under the mouse,
;;; to the best of our knowledge, or Nil if the mouse isn't over an item that
;;; does anything with its Tracker method.

(defvar *current-item* nil)


;;; Display-Item invokes the Display method of an item to put it up on the
;;; specified window.  The window, position, and size are all set, and the
;;; size is returned.

(defun display-item (item window x y)
  (setf (display-item-window item) window
	(display-item-x item) x
	(display-item-y item) y)
  (multiple-value-bind
      (width height)
      (funcall (display-item-display item) item window x y)
    (setf (display-item-width item) width)
    (setf (display-item-height item) height)
    (values width height)))

;;; Redisplay-Item redraws an item (if, say, it's changed, or if its window
;;; has received an exposure event).  If the item is the *Current-Item*,
;;; we call its tracker method to make sure it gets highlighted if it's
;;; supposed to be.

(defun redisplay-item (item)
  (when (display-item-window item)
    (xlib:clear-area (display-item-window item)
		     :x (display-item-x item) :y (display-item-y item)
		     :width (display-item-width item)
		     :height (display-item-height item))
    (multiple-value-bind
	(width height)
	(funcall (display-item-display item) item
		 (display-item-window item)
		 (display-item-x item) (display-item-y item))
      (setf (display-item-width item) width)
      (setf (display-item-height item) height))
    (xlib:display-force-output *display*)
    (when (and *current-item*
	       (eq (display-item-window *current-item*)
		   (display-item-window item)))
      (track-mouse *current-item* *mouse-x* *mouse-y*))))

;;; Size-Item uses the Display method to calculate the size of an item
;;; once displayed.  If the window supplied to Display-Item is Nil, all
;;; the size calculation will get done, but no graphical output will
;;; happen.

(defun size-item (item)
  (if (display-item-width item)
      (values (display-item-width item) (display-item-height item))
      (display-item item nil 0 0)))


;;; Walk-Item calls the Walker method of the given Item.  Walk-Item-List
;;; is used by some methods to walk down a list of items they have inside
;;; themselves.

(defun walk-item (item function)
  (funcall (display-item-walker item) item function))

(defun walk-item-list (list function)
  (dolist (item list)
    (when (display-item-p item)
      (walk-item item function))))


;;; The Nothing-Walker is used by guys that don't have any object items
;;; inside them.

(defun nothing-walker (self function)
  (declare (ignore self function)))


;;; Tracking and untracking.

;;; Track-Item and Untrack-Item call the right methods of the given Item.

(defun track-item (item x y)
  (funcall (display-item-tracker item) item x y))

(defun untrack-item (item)
  (funcall (display-item-untracker item) item))

;;; Update-Current-Item is used by trackers to figure out if an item
;;; is really under the mouse.  If it is, and it's not the same as the
;;; *Current-Item*, the *Current-Item* gets untracked.  If the mouse is
;;; inside the current item, Update-Current-Item returns T.

(defun update-current-item (item x y)
  (let ((old-current *current-item*))
    (if (and (<= (display-item-x item) x
		 (+ (display-item-x item) (display-item-width item)))
	     (<= (display-item-y item) y
		 (+ (display-item-y item) (display-item-height item))))
	(setq *current-item* item)
	(setq *current-item* nil))
    (when (and old-current (not (eq *current-item* old-current)))
      (untrack-item old-current)))
  (eq item *current-item*))


;;; The Nothing-Tracker and Nothing-Untracker don't do much.

(defun nothing-tracker (item x y)
  (update-current-item item x y))

(defun nothing-untracker (item)
  (declare (ignore item)))


;;; The Boxifying-Tracker and Boxifying-Untracker highlight and unhighlight
;;; an item by drawing or erasing a box around the object.

(defun boxifying-tracker (item x y)
  (when (update-current-item item x y)
    (boxify-item item boole-1)))

(defun boxifying-untracker (item)
  (boxify-item item boole-c1))

(defun boxify-item (item function)
  (let ((x1 (display-item-x item))
	(y1 (display-item-y item))
	(width (display-item-width item))
	(height (- (display-item-height item) 2))
	(window (display-item-window item)))
    (xlib:with-gcontext (*gcontext* :function function)
      (xlib:draw-rectangle window *gcontext* x1 y1 width height))
    (xlib:display-force-output *display*)))

;;; Track-In-List tries to track inside of each item in the List.

(defun track-in-list (list x y)
  (dolist (item list)
    (when (display-item-p item)
      (when (and (<= (display-item-x item) x
		     (+ (display-item-x item) (display-item-width item)))
		 (<= (display-item-y item) y
		     (+ (display-item-y item) (display-item-height item))))
	(track-item item x y)
	(return-from track-in-list nil))))
  (when *current-item*
    (untrack-item *current-item*)
    (setq *current-item* nil)))

;;;; Specialized Display-Item definitions.

;;; Inspection-Items are used as the "top-level" items in the display of an
;;; object.  They've got a list of header items and a list of entry items.
;;;
(defstruct (inspection-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-inspection-item)
		      (tracker 'track-inspection-item)
		      (walker 'walk-inspection-item))
	    (:constructor make-inspection-item (objects headers entries)))
  objects		; Objects being inspected (for decaching)
  headers		; List of items in header, may be Nil
  entries		; List of items below header
  )

;;; Scrolling-Inspection-Items are used as the "top-level" of display of
;;; objects that have lots of components and so have to scroll.  In addition to
;;; headers and entries, they've got a scrollbar item and stuff so that the
;;; entries can lazily compute where they are and what they should display.
;;;
(defstruct (scrolling-inspection-item
	    (:print-function print-display-item)
	    (:include inspection-item
		      (tracker 'track-scrolling-inspection-item))
	    (:constructor make-scrolling-inspection-item
			  (objects headers entries scrollbar)))
  scrollbar		; Scrollbar display item
  set-next		; To set next state
  next			; To get & increment next state
  )

;;; A Scrollbar-Item has buttons and a thumb bar and the stuff it needs to figure
;;; out whatever it needs to figure out.

(defstruct (scrollbar-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-scrollbar-item)
		      (tracker 'track-scrollbar-item)
		      (untracker 'untrack-scrollbar-item)
		      (mouse-handler 'mouse-scrollbar-item))
	    (:constructor make-scrollbar-item
			  (first-index num-elements num-elements-displayed
			   next-element reset-index)))
  scrollee		; Item for which this guy's a scrollbar
  bottom		; Y coordinate of end (hack, hack)
  active-button
  first-index		; Index of first thing to be displayed
  next-element		; Function to extract next element to be displayed
  reset-index		; Function to reset internal index for next-element
  window-width		; Max X for scrollees
  bar-height		; Height of bar in pixels
  bar-top
  bar-bottom
  num-elements		; Number of elements in scrollee
  num-elements-displayed ; Number of elements displayed at once
  )

;;; Scrolling-Items are used as the entries in Scrolling-Inspection-Items.
;;; they know the scrollbar that moves them around so they can lazily do
;;; their stuff.

(defstruct (scrolling-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-scrolling-item)
		      (tracker 'track-scrolling-item)
		      (walker 'walk-scrolling-item))
	    (:constructor make-scrolling-item (scrollbar item)))
  scrollbar
  item
  )

;;; String-Items just have a string of text and a font that it gets displayed in.

(defstruct (string-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-string-item))
	    (:constructor make-string-item (string &optional (font *entry-font*))))
  string		; String to be displayed
  font			; Font in which to display it
  )

;;; Slot-Items have a string name for the slot (e.g., structure slot name or vector
;;; index) and an object item for the contents of the slot.  The Max-Name-Width
;;; is used so that all the slots in an inspection item can line their objects
;;; up nicely in a left-justified column.

(defstruct (slot-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-slot-item)
		      (tracker 'track-slot-item)
		      (walker 'walk-slot-item))
	    (:constructor make-slot-item (name object)))
  name			; String name of slot
  object		; Display item for contents of slot
  max-name-width	; Length of longest slot name in structure
  )

;;; List-Items are used to display several things on the same line, one after
;;; the other.

(defstruct (list-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-list-item)
		      (tracker 'track-list-item)
		      (walker 'walk-list-item))
	    (:constructor make-list-item (list)))
  list			; List of things to be displayed
  )

;;; Object-Items are used to display component Lisp objects.  They know where
;;; the object came from and how to get it again (for decaching) and how to
;;; change it (for modification).

(defstruct (object-item
	    (:print-function print-display-item)
	    (:include display-item
		      (display 'display-object-item)
		      (tracker 'boxifying-tracker)
		      (untracker 'boxifying-untracker)
		      (mouse-handler 'mouse-object-item)
		      (walker 'walk-object-item))
	    (:constructor make-object-item (object place index ref set)))
  object		; The Lisp object itself
  string		; String representation cache
  place			; Place where it came from
  index			; Index into where it came from
  ref			; Function to get object, given place and index
  set			; Function to set object, given place, index and new value
  )

;;; Object*-Items are like Object-Items except that sometimes they can be like
;;; string items and be not-selectable.

(defstruct (object*-item
	    (:print-function print-display-item)
	    (:include object-item
		      (display 'display-object*-item)
		      (tracker 'track-object*-item)
		      (untracker 'untrack-object*-item)
		      (mouse-handler 'mouse-object*-item))
	    (:constructor make-object*-item (string* object live place index ref set)))
  live
  string*)

;;; Inspection item methods (including Scrolling-Inspection-Items).

(defun display-inspection-item (self window x0 y0)
  (let ((y (+ y0 border))
	(x (+ x0 border))
	(max-width 0)
	(max-x 0)
	(first-entry-y nil)
	(header-end-y nil)
	(sb (if (scrolling-inspection-item-p self)
		(scrolling-inspection-item-scrollbar self))))
    (when sb
      (funcall (scrollbar-item-reset-index sb) sb))
    ;; First, header items.
    (when (inspection-item-headers self)
      (dolist (item (inspection-item-headers self))
	(multiple-value-bind (width height)
			     (display-item item window x y)
	  (incf y height)
	  (setq max-width (max max-width width))))
      (setq header-end-y y)
      (incf y vsp))
    (when sb
      (incf x (+ 16 border))
      (funcall (scrollbar-item-reset-index sb) sb))
    ;; Then do entry items.
    (let ((max-name-width 0))
      (setq first-entry-y y)
      ;; Figure out width of widest entry slot name.
      (dolist (item (inspection-item-entries self))
	(when (slot-item-p item)
	  (setq max-name-width
		(max max-name-width (length (slot-item-name item))))))
      (dolist (item (inspection-item-entries self))
	(when (slot-item-p item)
	  (unless (slot-item-max-name-width item)
	    (setf (slot-item-max-name-width item) max-name-width)))
	(multiple-value-bind (width height)
			     (display-item item window x y)
	  (incf y height)
	  (setq max-width (max max-width (+ width (if sb (+ 16 border) 0)))))))
    (setq max-x (+ x0 border max-width border))
    ;; Display scrollbar, if any.
    (when sb
      (setf (scrollbar-item-bottom sb) y)
      (display-item sb window (+ x0 border) first-entry-y)
      (unless (scrollbar-item-window-width sb)
	(setf (scrollbar-item-window-width sb) (- max-width 16 border))))
    ;; Finally, draw a box around the whole thing.
    (when window
      (draw-box window x0 y0 max-x y)
      (when header-end-y
	(xlib:draw-line window *gcontext* x0 header-end-y max-x header-end-y)))
    ;; And return size.
    (values (- max-x x0) (- (+ y border) y0))))

(defun track-inspection-item (self x y)
  (dolist (item (inspection-item-headers self))
    (when (and (<= (display-item-x item) x
		   (+ (display-item-x item) (display-item-width item)))
	       (<= (display-item-y item) y
		   (+ (display-item-y item) (display-item-height item))))
      (track-item item x y)
      (return-from track-inspection-item nil)))
  (track-in-list (inspection-item-entries self) x y))

(defun track-scrolling-inspection-item (self x y)
  (dolist (item (inspection-item-headers self))
    (when (and (<= (display-item-x item) x
		   (+ (display-item-x item) (display-item-width item)))
	       (<= (display-item-y item) y
		   (+ (display-item-y item) (display-item-height item))))
      (track-item item x y)
      (return-from track-scrolling-inspection-item nil)))
  (let ((sb (scrolling-inspection-item-scrollbar self)))
    (if (and (<= (display-item-x sb) x (+ (display-item-x sb)
					  (display-item-width sb)))
	     (<= (display-item-y sb) y (+ (display-item-y sb)
					  (display-item-height sb))))
	(track-item sb x y)
	(track-in-list (inspection-item-entries self) x y))))

(defun walk-inspection-item (self function)
  (let ((*x-constraint* (if (display-item-width self)
			    (+ (display-item-x self)
			       (display-item-width self)
			       (- border))
			    max-window-width)))
    (walk-item-list (inspection-item-headers self) function)
    (walk-item-list (inspection-item-entries self) function)))

;;; Scrollbar item methods.

;;; Yeah, we use a hard-wired constant 16 here, which is the width and height
;;; of the buttons.  Grody, yeah, but hey, "16" is only two keystrokes...

(defun display-scrollbar-item (self window x y)
  (when window
    (draw-bitmap window x y
		 (if (eq (scrollbar-item-active-button self) :top)
		     *up-arrow-i* *up-arrow*))
    (draw-bitmap window x (- (scrollbar-item-bottom self) 16)
		 (if (eq (scrollbar-item-active-button self) :bottom)
		     *down-arrow-i* *down-arrow*))
    (draw-box window x (+ y 16) (+ x 15) (- (scrollbar-item-bottom self) 17))
    (setf (scrollbar-item-bar-top self) (+ y 17)
	  (scrollbar-item-bar-bottom self) (- (scrollbar-item-bottom self) 17)
	  (scrollbar-item-bar-height self) (- (scrollbar-item-bar-bottom self)
					      (scrollbar-item-bar-top self)))
    (draw-block window x
		(+ (scrollbar-item-bar-top self)
		   (truncate (* (scrollbar-item-first-index self)
				(scrollbar-item-bar-height self))
			     (scrollbar-item-num-elements self)))
		(+ x 16)
		(- (scrollbar-item-bar-bottom self)
		   (truncate (* (- (scrollbar-item-num-elements self)
				   (+ (scrollbar-item-first-index self)
				      (scrollbar-item-num-elements-displayed self)))
				(scrollbar-item-bar-height self))
			     (scrollbar-item-num-elements self))))
    (xlib:display-force-output *display*))
  (values 16 (- (scrollbar-item-bottom self) y)))

(defun track-scrollbar-item (self x y)
  (update-current-item self x y)
  (cond ((<= (display-item-y self) y (+ (display-item-y self) 16))
	 (setf (scrollbar-item-active-button self) :top)
	 (draw-bitmap (display-item-window self) 
		      (display-item-x self) (display-item-y self) *up-arrow-i*))
	((<= (- (scrollbar-item-bottom self) 16) y (scrollbar-item-bottom self))
	 (setf (scrollbar-item-active-button self) :bottom)
	 (draw-bitmap (display-item-window self) 
		      (display-item-x self) (- (scrollbar-item-bottom self) 16)
		      *down-arrow-i*))
	(t
	 (untrack-scrollbar-item self)))
  (xlib:display-force-output *display*))

(defun untrack-scrollbar-item (self)
  (cond ((eq (scrollbar-item-active-button self) :top)
	 (draw-bitmap (display-item-window self)
		      (display-item-x self) (display-item-y self) *up-arrow*))
	((eq (scrollbar-item-active-button self) :bottom)
	 (draw-bitmap (display-item-window self)
		      (display-item-x self) (- (scrollbar-item-bottom self) 16)
		      *down-arrow*)))
  (xlib:display-force-output *display*)
  (setf (scrollbar-item-active-button self) nil))

;;; String item methods.

(defun display-string-item (self window x y)
  (disp-string window x y (string-item-string self) (string-item-font self)))

;;; Slot item methods.

(defun display-slot-item (self window x y)
  (let ((name (slot-item-name self))
	(name-pixel-width (* (+ 2 (slot-item-max-name-width self))
			     (font-width *entry-font*))))
    (disp-string window x y name *entry-font*)
    (multiple-value-bind (width height)
			 (display-item (slot-item-object self)
				       window (+ x name-pixel-width) y)
      (values (+ name-pixel-width width border)
	      (max (+ (font-height *entry-font*) vsp) height)))))

(defun track-slot-item (self x y)
  (track-item (slot-item-object self) x y))

(defun walk-slot-item (self function)
  (walk-item (slot-item-object self) function)
  (setf (display-item-width self)
	(+ (* (+ 2 (slot-item-max-name-width self)) (font-width *entry-font*))
	   (display-item-width (slot-item-object self))
	   border)))

;;; Scrolling item methods.

(defun display-scrolling-item (self window x y)
  (let ((sb (scrolling-item-scrollbar self))
	(item (scrolling-item-item self)))
    (funcall (scrollbar-item-next-element sb) item)
    (let ((*x-constraint* (if (scrollbar-item-window-width sb)
			      (+ (scrollbar-item-window-width sb) x)
			      max-window-width)))
      (multiple-value-bind (width height)
			   (display-item item window x y)
	(values (or (scrollbar-item-window-width sb) width)
		height)))))

(defun track-scrolling-item (self x y)
  (track-item (scrolling-item-item self) x y))

(defun walk-scrolling-item (self function)
  (walk-item (scrolling-item-item self) function))

;;; List item methods.

;;; If a thing in the item list is a string, we just Disp-String it.
;;; That way, we don't have to cons lots of full string items all the time.

(defun display-list-item (self window x0 y0)
  (let ((x x0)
	(max-height 0))
    (dolist (item (list-item-list self))
      (multiple-value-bind (width height)
			   (if (stringp item)
			       (disp-string window x y0 item *entry-font*)
			       (display-item item window x y0))
	(incf x width)
	(setq max-height (max max-height height))))
    (values (- x x0) max-height)))

(defun track-list-item (self x y)
  (track-in-list (list-item-list self) x y))

(defun walk-list-item (self function)
  (walk-item-list (list-item-list self) function))

;;; Object and Object* item methods.

(defun display-object-item (self window x y)
  (unless (object-item-string self)
    (setf (object-item-string self)
	  (iprin1-to-string (object-item-object self))))
  (disp-string window x y (object-item-string self) *entry-font*))

(defun walk-object-item (self function)
  (funcall function self))

(defun display-object*-item (self window x y)
  (if (object*-item-live self)
      (display-object-item self window x y)
      (disp-string window x y (object*-item-string* self) *italic-font*)))

(defun track-object*-item (self x y)
  (if (or (object*-item-live self) (eq *tracking-mode* :destination))
      (boxifying-tracker self x y)
      (update-current-item self x y)))

(defun untrack-object*-item (self)
  (when (or (object*-item-live self) (eq *tracking-mode* :destination))
    (boxifying-untracker self)))

;;; Computing display items for Lisp objects.

;;; Plan-Display returns a top-level Display-Item for the given Object.

(defun plan-display (object)
  (typecase object
    (pcl::std-instance (plan-display-object object))
    (structure-object (plan-display-structure object))
    (cons (plan-display-list object))
    (vector (plan-display-vector object))
    (array (plan-display-array object))
    (symbol (plan-display-symbol object))
    (compiled-function (plan-display-function object))
    (t (plan-display-atomic object))))

;;; Replan-Display tries to fix up the existing Plan if possible, but might
;;; punt and just return a new Display-Item if things have changed too much.

(defun replan-display (plan)
  (let ((object (inspection-item-objects plan)))
    (typecase object
      (pcl::std-instance (replan-display-object plan object))
      (structure-object (replan-display-structure plan object))
      (cons (replan-display-list plan object))
      (vector (replan-display-vector plan object))
      (array (replan-display-array plan object))
      (symbol (replan-display-symbol plan object))
      (compiled-function plan)
      (t (replan-display-atomic plan object)))))

;;; Replan-Object-Item is used at the leaves of the replanning walk.

(defun replan-object-item (item)
  (if (object*-item-p item)
      (multiple-value-bind (decached-object live)
			   (funcall (object-item-ref item)
				    (object-item-place item) (object-item-index item))
	(unless (and (eq live (object*-item-live item))
		     (eq decached-object (object-item-object item))
		     (or (symbolp decached-object) (numberp decached-object)
			 ;; ...
			 ))
	  (setf (object*-item-live item) live)
	  (setf (object-item-object item) decached-object)
	  (setf (object-item-string item) nil)
	  (redisplay-item item)))
      (let ((decached-object (funcall (object-item-ref item)
				      (object-item-place item) (object-item-index item))))
	(unless (and (eq decached-object (object-item-object item))
		     (or (symbolp decached-object) (numberp decached-object)
			 ;; ... any others that'll be the same?
			 ))
	  (setf (object-item-object item) decached-object)
	  (setf (object-item-string item) nil)
	  (redisplay-item item)))))

;;; For lists, what we stash in the Inspection-Item-Objects slot is the list of
;;; the top level conses, rather than the conses themselves.  This lets us detect
;;; when conses "in the middle" of the list change.

(defun plan-display-list (object)
  (cond #|((and (symbolp (car object))
	      (get (car object) 'lisp::specially-grind))
	   (error "Bliue"))|#
	((or (and (< (length (iprin1-to-string object)) inspect-line-length)
		  (<= (length object) inspect-length))
	     (= (length object) 1))
	 (do ((list object (cdr list))
	      (items (list "(")))
	     ((not (consp (cdr list)))
	      (push (make-object-item (car list) list nil 'lref 'lset) items)
	      (when (not (null (cdr list)))
		(push " . " items)
		(push (make-object-item (cdr list) list nil 'lref* 'lset*) items))
	      (push ")" items)
	      (make-inspection-item
	       (copy-conses object)
	       nil
	       (list (make-list-item (nreverse items)))))
	   (push (make-object-item (car list) list nil 'lref 'lset) items)
	   (push " " items)))
	((<= (length object) inspect-length)
	 (let ((items nil))
	   (push (make-list-item (list "("
				       (make-object-item
					(car object) object nil 'lref 'lset)))
		 items)
	   (do ((list (cdr object) (cdr list)))
	       ((not (consp (cdr list)))
		(cond ((null (cdr list))
		       (push (make-list-item (list " "
						   (make-object-item
						    (car list) list nil 'lref 'lset)
						   ")"))
			     items))
		      (t
		       (push (make-list-item (list " "
						   (make-object-item
						    (car list) list nil 'lref 'lset)))
			     items)
		       (push " ." items)
		       (push (make-list-item (list " "
						   (make-object-item
						    (cdr list) list nil 'lref* 'lset*)
						   ")"))
			     items))))
	     (push (make-list-item (list " "
					 (make-object-item
					  (car list) list nil 'lref 'lset)))
		   items))
	   (make-inspection-item (copy-conses object) nil (nreverse items))))
	(t
	 (let ((scrollbar
		(let ((index 0)
		      (cons object)
		      (last (last object)))
		  (make-scrollbar-item
		   0
		   (+ (length object) (if (cdr last) 1 0))
		   inspect-length
		   #'(lambda (item)
		       (setf (list-item-list item)
			     `(,(cond ((eq cons object)
				       "(")
				      ((not (consp cons))
				       " . ")
				      (t
				       " "))
			       ,(if (consp cons)
				    (make-object-item (car cons) cons nil 'lref 'lset)
				    (make-object-item cons last nil 'lref* 'lset*))
			       ,@@(if (or (and (eq cons last) (null (cdr cons)))
					 (atom cons))
				     `(")"))))
		       (incf index)
		       (unless (atom cons)
			 (setq cons (cdr cons))))
		   #'(lambda (self)
		       (setq index (scrollbar-item-first-index self))
		       (setq cons (nthcdr index object)))))))
	   (setf (scrollbar-item-scrollee scrollbar)
		 (make-scrolling-inspection-item
		  (copy-conses object)
		  nil
		  (let ((items nil))
		    (dotimes (i inspect-length)
		      (push (make-scrolling-item scrollbar (make-list-item nil))
			    items))
		    (nreverse items))
		  scrollbar)))
	 )))

;;; This is kind of like (maplist #'identity list), except that it doesn't
;;; choke on non-Nil terminated lists.

(defun copy-conses (list)
  (do ((list list (cdr list))
       (conses nil))
      ((atom list)
       (nreverse conses))
    (push list conses)))

(defun replan-display-list (plan object)
  (cond ((do ((list (car object) (cdr list))
	      (conses object (cdr conses)))
	     ((or (null list) (null conses))
	      (and (null list) (null conses)))
	   (unless (and (eq list (car conses))
			(eq (cdr list) (cadr conses)))
	     (return nil)))
	 (walk-item plan #'replan-object-item)
	 plan)
	(t
	 (plan-display (car object)))))

(defun lref (object ignore) (declare (ignore ignore))
  (car object))
(defun lref* (object ignore) (declare (ignore ignore))
  (cdr object))
(defun lset (object ignore new) (declare (ignore ignore))
  (setf (car object) new))
(defun lset* (object ignore new) (declare (ignore ignore))
  (setf (cdr object) new))

(defun plan-display-vector (object)
  (let* ((type (type-of object))
	 (length (array-dimension object 0))
	 (header
	  `(,(make-string-item (format nil "~A" (if (listp type) (car type) type))
			       *header-font*)
	    ,(make-string-item (format nil "Length = ~D" length)
			       *header-font*)
	    ,@@(if (array-has-fill-pointer-p object)
		  `(,(make-list-item (list "Fill-Pointer: "
					   (make-object-item
					    (fill-pointer object)
					    object nil 'fpref 'fpset))))))))
     (cond ((<= length inspect-length)
	    (make-inspection-item
	     object
	     header
	     (let ((items nil))
	       (dotimes (i length)
		 (push (make-slot-item (prin1-to-string i)
				       (make-object-item
					(aref object i) object i 'vref 'vset))
		       items))
	       (nreverse items))))
	   (t
	    (let ((scrollbar
		   (let ((index 0))
		     (make-scrollbar-item
		      0
		      length
		      inspect-length
		      #'(lambda (item)
			  (setf (slot-item-name item) (prin1-to-string index))
			  (let ((obj (slot-item-object item)))
			    (setf (object-item-object obj) (aref object index))
			    (setf (object-item-index obj) index)
			    (setf (object-item-string obj) nil))
			  (incf index))
		      #'(lambda (self)
			  (setq index (scrollbar-item-first-index self)))))))
	      (setf (scrollbar-item-scrollee scrollbar)
		    (make-scrolling-inspection-item
		     object
		     header
		     (let ((items nil)
			   (name-width (length (iprin1-to-string (1- length)))))
		       (dotimes (i inspect-length)
			 (let ((slot
				(make-slot-item
				 nil
				 (make-object-item nil object nil 'vref 'vset))))
			   (setf (slot-item-max-name-width slot) name-width)
			   (push (make-scrolling-item scrollbar slot) items)))
		       (nreverse items))
		     scrollbar)))))))

(defun replan-display-vector (plan object)
  (cond ((= (length object) (length (inspection-item-objects plan)))
	 (walk-item plan #'replan-object-item)
	 plan)
	(t
	 (plan-display object))))

(defun vref (object index)
  (aref object index))
(defun vset (object index new)
  (setf (aref object index) new))

(defun fpref (object index)
  (declare (ignore index))
  (fill-pointer object))
(defun fpset (object index new)
  (declare (ignore index))
  (setf (fill-pointer object) new))

(defun plan-display-array (object)
  (lisp::with-array-data ((data object)
			  (start)
			  (end))
    (let* ((length (- end start))
	   (dimensions (array-dimensions object))
	   (rev-dimensions (reverse dimensions))
	   (header
	    (list (make-string-item
		   (format nil "Array of ~A" (array-element-type object))
		   *header-font*)
		  (make-string-item
		   (format nil "Dimensions = ~S" dimensions)
		   *header-font*))))
      (cond ((<= length inspect-length)
	     (make-inspection-item
	      object
	      header
	      (let ((items nil))
		(dotimes (i length)
		  (push (make-slot-item (index-string i rev-dimensions)
					(make-object-item
					 (aref data (+ start i))
					 object (+ start i) 'vref 'vset))
			items))
		(nreverse items))))
	    (t
	     (let ((scrollbar
		    (let ((index 0))
		      (make-scrollbar-item
		       0
		       length
		       inspect-length
		       #'(lambda (item)
			   (setf (slot-item-name item)
				 (index-string index rev-dimensions))
			   (let ((obj (slot-item-object item)))
			     (setf (object-item-object obj)
				   (aref data (+ start index)))
			     (setf (object-item-index obj) (+ start index))
			     (setf (object-item-string obj) nil))
			   (incf index))
		       #'(lambda (self)
			   (setq index (scrollbar-item-first-index self)))))))
	       (setf (scrollbar-item-scrollee scrollbar)
		     (make-scrolling-inspection-item
		      object
		      header
		      (let ((items nil)
			    (name-width (length (index-string (1- length)
							      rev-dimensions))))
			(dotimes (i inspect-length)
			  (let ((slot
				 (make-slot-item
				  nil
				  (make-object-item nil data nil 'vref 'vset))))
			    (setf (slot-item-max-name-width slot) name-width)
			    (push (make-scrolling-item scrollbar slot) items)))
			(nreverse items))
		      scrollbar))))))))

(defun index-string (index rev-dimensions)
  (if (null rev-dimensions)
      "[]"
      (let ((list nil))
	(dolist (dim rev-dimensions)
	  (multiple-value-bind (q r)
			       (floor index dim)
	    (setq index q)
	    (push r list)))
	(format nil "[~D~{,~D~}]" (car list) (cdr list)))))

(defun replan-display-array (plan object)
  (cond ((and (equal (array-dimensions object)
		     (array-dimensions (inspection-item-objects plan)))
	      (lisp::with-array-data ((data1 object)
				      (start1) (end1))
		(lisp::with-array-data ((data2 (inspection-item-objects plan))
					(start2) (end2))
		  (and (eq data1 data2)
		       (= start1 start2)
		       (= end1 end2)))))
	 (walk-item plan #'replan-object-item)
	 plan)
	(t
	 (plan-display object))))

(defun plan-display-atomic (object)
  (make-inspection-item
   object
   nil
   (list (make-object-item object (list object) nil 'lref 'lset))))

(defun replan-display-atomic (plan object)
  (declare (ignore object))
  (walk-item plan #'replan-object-item)
  plan)

(defun plan-display-structure (object)
  (let* ((dd (layout-info (%instance-layout object)))
	 (dsds (dd-slots dd)))
    (make-inspection-item
     object
     (list (make-string-item (format nil "~A ~A"
				     (symbol-name (dd-name dd))
				     object)
			     *header-font*))
     (let ((items nil))
       (dolist (dsd dsds)
	 (push (make-slot-item
		(dsd-%name dsd)
		(make-object-item
		 (funcall (fdefinition (dsd-accessor dsd)) object)
		 object (dsd-index dsd)
		 #'(lambda (str ignore)
		     (declare (ignore ignore))
		     (funcall (fdefinition (dsd-accessor dsd))
			      str))
		 #'(lambda (str ignore val)
		     (declare (ignore ignore))
		     (funcall (fdefinition `(setf ,(dsd-accessor dsd)))
			      val str))))
	       items))
       (nreverse items)))))

(defun replan-display-structure (plan object)
  (declare (ignore object))
  (walk-item plan #'replan-object-item)
  plan)

(defun plan-display-object (object)
  (let ((class (pcl::class-of object)))
    (make-inspection-item
     object
     (list (make-string-item (format nil "~S ~A"
				     (pcl:class-name class)
				     object)
			     *header-font*))
     (let ((slotds (pcl::slots-to-inspect class object))
	   instance-slots class-slots other-slots)
       (dolist (slotd slotds)
	 (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
			 slotd
	   (let ((item (make-slot-item (prin1-to-string slot)
				       (make-object*-item
					"Unbound"
					(if (pcl:slot-boundp object slot)
					    (pcl:slot-value object slot))
					(pcl:slot-boundp object slot)
					object
					slot
					'ref-slot
					'set-slot))))
	     (case allocation
	       (:instance (push item instance-slots))
	       (:class (push item class-slots))
	       (otherwise
		(setf (slot-item-name item)
		      (format nil "~S [~S]" slot allocation))
		(push item other-slots))))))
       (append (unless (null instance-slots)
		 (cons (make-string-item "These slots have :INSTANCE allocation"
					 *entry-font*)
		       (nreverse instance-slots)))
	       (unless (null class-slots)
		 (cons (make-string-item "These slots have :CLASS allocation"
					 *entry-font*)
		       (nreverse class-slots)))
	       (unless (null other-slots)
		 (cons (make-string-item "These slots have allocation as shown"
					 *entry-font*)
		       (nreverse other-slots))))))))

(defun ref-slot (object slot)
  (if (pcl:slot-boundp object slot)
    (values (pcl:slot-value object slot) t)
    (values nil nil)))

(defun set-slot (object slot val)
  (setf (pcl:slot-value object slot) val))

;;; Should check to see if we need to redo the entire plan or not.
(defun replan-display-object (plan object)
  (declare (ignore plan))
  (plan-display object))


(defun plan-display-symbol (object)
  (make-inspection-item
   object
   (list (make-string-item (format nil "Symbol ~A" object) *header-font*))
   (list (make-slot-item "Value"
			 (make-object*-item
			  "Unbound" (if (boundp object) (symbol-value object))
			  (boundp object) object nil 'valref 'valset))
	 (make-slot-item "Function"
			 (make-object*-item
			  "Undefined" (if (fboundp object) (symbol-function object))
			  (fboundp object) object nil 'defref 'defset))
	 (make-slot-item "Properties"
			 (make-object-item
			  (symbol-plist object) object nil 'plistref 'plistset))
	 (make-slot-item "Package"
			 (make-object-item
			  (symbol-package object) object nil 'packref 'packset)))))

(defun replan-display-symbol (plan object)
  (declare (ignore object))
  (walk-item plan #'replan-object-item)
  plan)

(defun valref (object ignore) (declare (ignore ignore))
  (if (boundp object)
      (values (symbol-value object) t)
      (values nil nil)))
(defun defref (object ignore) (declare (ignore ignore))
  (if (fboundp object)
      (values (symbol-function object) t)
      (values nil nil)))
(defun plistref (object ignore) (declare (ignore ignore))
  (symbol-plist object))
(defun packref (object ignore) (declare (ignore ignore))
  (symbol-package object))

(defun valset (object ignore new) (declare (ignore ignore))
  (setf (symbol-value object) new))
(defun defset (object ignore new) (declare (ignore ignore))
  (setf (symbol-function object) new))
(defun plistset (object ignore new) (declare (ignore ignore))
  (setf (symbol-plist object) new))
(defun packset (object ignore new) (declare (ignore ignore))
  (lisp::%set-symbol-package object new))

;;; This is all very gross and silly now, just so we can get something working
;;; quickly. Eventually do this with a special stream that listifies things as
;;; it goes along...

(defun plan-display-function (object)
  (let ((stream (make-string-output-stream)))
    (let ((*standard-output* stream))
      (describe object)
      #+nil
      (compiler::output-macro-instructions object nil))
    (close stream)
    (with-input-from-string (in (get-output-stream-string stream))
      (plan-display-text
       object
       nil
       #+nil
       (list
	(make-string-item (format nil "Function ~S" object) *header-font*)
	(make-string-item
	 (format nil "Argument list: ~A"
		 (lisp::%sp-header-ref object lisp::%function-arg-names-slot)))
	(make-string-item
	 (format nil "Defined from:  ~A"
		 (lisp::%sp-header-ref object
				       lisp::%function-defined-from-slot))))
       in))))

(defun plan-display-text (object header stream)
  (let ((list nil))
    (do ((line (read-line stream nil nil) (read-line stream nil nil)))
	((null line))
      (push line list))
    (setq list (nreverse list))
    (if (<= (length list) inspect-length)
	(make-inspection-item
	 object
	 header
	 (mapcar #'make-string-item list))
	(let ((index 0)
	      (vector (coerce list 'vector)))
	  (let ((scrollbar (make-scrollbar-item
			    0 (length list) inspect-length
			    #'(lambda (item)
				(setf (string-item-string item)
				      (aref vector index))
				(incf index))
			    #'(lambda (self)
				(setq index
				      (scrollbar-item-first-index self))))))
	    (setf (scrollbar-item-scrollee scrollbar)
		  (make-scrolling-inspection-item
		   object
		   header
		   (let ((items nil))
		     (dotimes (i inspect-length)
		       (push (make-scrolling-item scrollbar
						  (make-string-item ""))
			     items))
		     (nreverse items))
		   scrollbar)))))))

;;; Displaying old and new plans in old and new windows.

(defun new-plan-in-new-display (object plan &optional name)
  (multiple-value-bind (width height) (size-item plan)
    ;; add border
    (incf width 10)
    (incf height 10)
    (multiple-value-bind (x y) (next-window-position width height)
      (let* ((window (xlib:create-window :parent *root* :x x :y y
					 :width width :height height
					 :background *white-pixel*
					 :border-width 2))
	     (display-info (make-display-info name object plan window)))
	(xlib:set-wm-properties window
				:name "Inspector Window"
				:icon-name "Inspector Display"
				:resource-name "Inspector"
				:x x :y y :width width :height height
				:user-specified-position-p t
				:user-specified-size-p t
				:min-width width :min-height height
				:width-inc nil :height-inc nil)
	(add-window-display-info-mapping window display-info)
	(xlib:map-window window)
	(xlib:clear-area window)
	(xlib:with-state (window)
	  (setf (xlib:window-event-mask window) important-xevents-mask)
	  (setf (xlib:window-cursor window) *cursor*))
	(xlib:display-finish-output *display*)
	(display-item plan window 5 5)
	(push display-info *display-infos*)
	(multiple-value-bind
	    (x y same-screen-p child mask root-x root-y root)
	    (xlib:query-pointer window)
	  (declare (ignore same-screen-p child mask root-x root-y root))
	  (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10)))
	    (track-mouse plan x y)))
	(xlib:display-force-output *display*)
	display-info))))

(defun create-display-of-object (object &optional name)
  (new-plan-in-new-display object (plan-display object) name))

(defun new-plan-in-old-display (display-info old new)
  (unless (eq new old)
    (setf (display-info-display-item display-info) new)
    (let ((window (display-info-window display-info)))
      (when (and *current-item*
		 (eql (display-item-window *current-item*) window))
	(setq *current-item* nil))
      (multiple-value-bind (width height)
			   (size-item new)
	(xlib:with-state (window)
	  (setf (xlib:drawable-width window) (+ width 10))
	  (setf (xlib:drawable-height window) (+ height 10)))
	(xlib:clear-area window)
	(display-item new window 5 5)
	(setf (display-item-window new) window
	      (display-item-x new) 5
	      (display-item-y new) 5
	      (display-item-width new) width
	      (display-item-height new) height)
	(xlib:display-force-output *display*)
	(multiple-value-bind
	    (x y same-screen-p child mask root-x root-y root)
	    (xlib:query-pointer window)
	  (declare (ignore same-screen-p child mask root-x root-y root))
	  (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10)))
	    (track-mouse new x y)))))))

(defun update-display-of-object (display-info
				 &optional
				 (object (display-info-object display-info)))
  (cond ((eq object (display-info-object display-info))
	 (new-plan-in-old-display display-info
				  (display-info-display-item display-info)
				  (replan-display
				   (display-info-display-item display-info))))
	(t
	 (setf (display-info-object display-info) object)
	 (new-plan-in-old-display display-info
				  (display-info-display-item display-info)
				  (plan-display object))))
  (xlib:display-force-output *display*))


;;; DELETING-WINDOW-DROP-EVENT checks for any events on win.  If there is one,
;;; it is removed from the queue, and t is returned.  Otherwise, returns nil.
;;;
(defun deleting-window-drop-event (display win)
  (xlib:display-finish-output display)
  (let ((result nil))
    (xlib:process-event
     display :timeout 0
     :handler #'(lambda (&key event-window window &allow-other-keys)
		  (if (or (eq event-window win) (eq window win))
		      (setf result t)
		      nil)))
    result))

(defun remove-display-of-object (display-info)
  (let ((window (display-info-window display-info)))
    (setf (xlib:window-event-mask window) #.(xlib:make-event-mask))
    (xlib:display-finish-output *display*)
    (loop (unless (deleting-window-drop-event *display* window) (return)))
    (xlib:destroy-window window)
    (xlib:display-finish-output *display*)
    (delete-window-display-info-mapping window)
    (setq *display-infos* (delete display-info *display-infos*))))



;;; The command interpreter.


(defvar *can-quit* nil)
(defvar *can-proceed* nil)
(defvar *unwinding* t)

(defun try-to-quit ()
  (setq *current-item* nil)
  (when *can-quit*
    (setq *unwinding* nil)
    (ext:flush-display-events *display*)
    (throw 'inspect-exit nil))
  (try-to-proceed))

(defun try-to-proceed ()
  (when *can-proceed*
    (setq *unwinding* nil)
    (ext:flush-display-events *display*)
    (throw 'inspect-proceed nil)))

(defvar *do-command* nil)

(defun do-command (display-info key-event)
  (cond (*do-command*
	 (funcall *do-command* display-info key-event))
	((or (eq key-event #k"d") (eq key-event #k"D"))
	 ;; Delete current window.
	 (remove-display-of-object display-info)
	 (setq *current-item* nil)
	 (unless *display-infos*
	   (try-to-quit)
	   (try-to-proceed)))
	((or (eq key-event #k"h") (eq key-event #k"H") (eq key-event #k"?"))
	 (let ((inspect-length (max inspect-length 30)))
	   (with-open-file (stream help-file-pathname :direction :input)
	     (new-plan-in-new-display
	      nil
	      (plan-display-text nil
				 (list (make-string-item "Help" *header-font*))
				 stream)))))
	((or (eq key-event #k"m") (eq key-event #k"M"))
	 ;; Modify something.
	 ;; Since the tracking stuff sets up event handlers that can throw past
	 ;; the CLX event dispatching form in INSPECTOR-EVENT-HANDLER, those
	 ;; handlers are responsible for discarding their events when throwing
	 ;; to this CATCH tag.
	 ;;
	 (catch 'quit-modify
	   (let* ((destination-item (track-for-destination))
		  (source (cond
			   ((eq key-event #k"m")
			    (object-item-object (track-for-source)))
			   (t
			    (format *query-io*
				    "~&Form to evaluate for new contents: ")
			    (force-output *query-io*)
			    (eval (read *query-io*))))))
	     (funcall (object-item-set destination-item)
		      (object-item-place destination-item)
		      (object-item-index destination-item)
		      source)
	     (update-display-of-object display-info))))
	((or (eq key-event #k"q") (eq key-event #k"Q"))
	 ;; Quit.
	 (try-to-quit))
	((or (eq key-event #k"p") (eq key-event #k"P"))
	 ;; Proceed.
	 (try-to-proceed))
	((or (eq key-event #k"r") (eq key-event #k"R"))
	 ;; Recompute object (decache).
	 (update-display-of-object display-info))
	((or (eq key-event #k"u") (eq key-event #k"U"))
	 ;; Up (pop history stack).
	 (when (display-info-stack display-info)
	   (let ((parent (pop (display-info-stack display-info))))
	     (setf (display-info-object display-info) (car parent))
	     (new-plan-in-old-display display-info
				      (display-info-display-item display-info)
				      (cdr parent))
	     (update-display-of-object display-info))))
	((or (eq key-event #k"Leftdown")
	     (eq key-event #k"Middledown")
	     (eq key-event #k"Rightdown")
	     (eq key-event #k"Super-Leftdown")
	     (eq key-event #k"Super-Middledown")
	     (eq key-event #k"Super-Rightdown"))
	 (when *current-item*
	   (funcall (display-item-mouse-handler *current-item*)
		    *current-item* display-info key-event)))))


;;; Stuff to make modification work.

(defun track-for-destination ()
  (track-for :destination *cursor-d*))

(defun track-for-source ()
  (track-for :source *cursor-s*))

;;; TRACK-FOR loops over SYSTEM:SERVE-EVENT waiting for some event handler
;;; to throw to this CATCH tag.  Since any such handler throws past
;;; SYSTEM:SERVE-EVENT, and therefore, past the CLX event dispatching form
;;; in INSPECTOR-EVENT-HANDLER, it is that handler's responsibility to
;;; discard its event.
;;;
(defun track-for (tracking-mode cursor)
  (let ((*tracking-mode* tracking-mode)
	(*do-command* #'track-for-do-command))
    (catch 'track-for
      (unwind-protect
	  (progn
	    (dolist (display-info *display-infos*)
	      (setf (xlib:window-cursor (display-info-window display-info))
		    cursor))
	    (xlib:display-force-output *display*)
	    (loop (system:serve-event)))
	(dolist (display-info *display-infos*)
	  (setf (xlib:window-cursor (display-info-window display-info))
		*cursor*))
	(xlib:display-force-output *display*)))))

;;; TRACK-FOR-DO-COMMAND is the "DO-COMMAND" executed when tracking.  Since
;;; this throws past the CLX event handling form in INSPECTOR-EVENT-HANDLER,
;;; the responsibility for discarding the current event lies here.
;;;
(defun track-for-do-command (display-info key-event)
  (declare (ignore display-info))
  (cond
    ((or (eq key-event #k"q") (eq key-event #k"Q"))
     (xlib:discard-current-event *display*)
     (throw 'quit-modify t))
    ((or (eq key-event #k"Leftdown")
	 (eq key-event #k"Middledown")
	 (eq key-event #k"Rightdown"))
     (when (object-item-p *current-item*)
       (throw 'track-for
	      (prog1 *current-item*
		(when (object*-item-p *current-item*)
		  (untrack-item *current-item*)
		  (setq *current-item* nil))
		(xlib:discard-current-event *display*)))))))



;;; Mouse handler methods (here because they're more like part of the command
;;; loop).

(defvar *inspect-result*)

(defun nothing-mouse-handler (self display-info key-event)
  (declare (ignore self display-info key-event))
  )

(defun mouse-object-item (self display-info key-event)
  (cond
    ((eq key-event #k"Leftdown")
     ;; Open in current window
     (push (cons (display-info-object display-info)
		 (display-info-display-item display-info))
	   (display-info-stack display-info))
     (update-display-of-object display-info (object-item-object self)))
    ((eq key-event #k"Rightdown")
     ;; Open in new window
     (create-display-of-object (object-item-object self)))
    ((eq key-event #k"Middledown")
     ;; Return object from inspect
     (setq *inspect-result* (object-item-object self))
     (try-to-quit))
    ((eq key-event #k"Super-Middledown")
     ;; Return object by leave windows around
     (setq *inspect-result* (object-item-object self))
     (try-to-proceed))))

(defun mouse-object*-item (self display-info key-event)
  (when (object*-item-live self)
    (mouse-object-item self display-info key-event)))

(defun mouse-scrollbar-item (self display-info key-event)
  (declare (ignore display-info))
  (let* ((old-first (scrollbar-item-first-index self))
	 (new-first old-first))
    (cond ((eq (scrollbar-item-active-button self) :bottom)
	   (incf new-first (if (eq key-event #k"Rightdown")
			       (scrollbar-item-num-elements-displayed self)
			       1)))
	  ((eq (scrollbar-item-active-button self) :top)
	   (decf new-first (if (eq key-event #k"Rightdown")
			       (scrollbar-item-num-elements-displayed self)
			       1)))
	  ((<= (scrollbar-item-bar-top self) *mouse-y*
	       (scrollbar-item-bar-bottom self))
	   (setq new-first (truncate (* (- *mouse-y* (scrollbar-item-bar-top self))
					(scrollbar-item-num-elements self))
				     (scrollbar-item-bar-height self)))))
    (setq new-first (max new-first 0))
    (setq new-first (min new-first
			 (- (scrollbar-item-num-elements self)
			    (scrollbar-item-num-elements-displayed self))))
    (unless (= new-first old-first)
      (setf (scrollbar-item-first-index self) new-first)
      (funcall (scrollbar-item-reset-index self) self)
      (dolist (item (scrolling-inspection-item-entries
		     (scrollbar-item-scrollee self)))
	(redisplay-item item))
      (redisplay-item self))))

(defun track-mouse (item x y)
  (track-item item x y))

;;; Top-level program interface.

(defun show-object (object &optional name)
  (inspect-init)
  (dolist (display-info *display-infos*)
    (when (if name
	      (eq name (display-info-name display-info))
	      (eq object (display-info-object display-info)))
      (update-display-of-object display-info object)
      (return-from show-object nil)))
  (create-display-of-object object name))

(defun remove-object-display (object &optional name)
  (dolist (display-info *display-infos*)
    (when (if name
	      (eq name (display-info-name display-info))
	      (eq object (display-info-object display-info)))
      (remove-display-of-object display-info)
      (return nil))))

(defun remove-all-displays ()
  (dolist (display-info *display-infos*)
    (remove-display-of-object display-info)))



;;; Top-level user interface.

(defvar *interface-style* :graphics
  "This specifies the default value for the interface argument to INSPECT.  The
   default value of this is :graphics, indicating when running under X, INSPECT
   should use a graphics interface instead of a command-line oriented one.")

(defun inspect (&optional (object nil object-p)
			  (interface *interface-style*))
  "This function allows the user to interactively examine Lisp objects.
   Interface indicates whether this should run with a :graphics interface or a
   :command-line oriented one; of course, when running without X, there is no
   choice.  Supplying :window, :windows, :graphics, :graphical, and :x gets a
   windowing interface, and supplying :command-line or :tty gets the other
   style.  Invoking this with no arguments resumes inspection of items left
   active from previous uses, but this only works when running under X."
  (cond ((or (member interface '(:command-line :tty))
	     (not (assoc :display ext:*environment-list*)))
	 (when object-p (tty-inspect object)))
	((not (member interface '(:window :windows :graphics :graphical :x)))
	 (error "Interface must be one of :window, :windows, :graphics, ~
		 :graphical, :x, :command-line, or :tty -- not ~S."
		interface))
	(object-p
	 (inspect-init)
	 (let ((disembodied-display-infos nil)
	       (*inspect-result* object)
	       (*x-constraint* max-window-width)
	       (*can-quit* t)
	       (*can-proceed* t))
	   (let ((*display-infos* nil))
	     (create-display-of-object object)
	     (catch 'inspect-proceed
	       (unwind-protect
		   (progn
		     (catch 'inspect-exit
		       (loop (system:serve-event)))
		     (setq *unwinding* t))
		 (when *unwinding*
		   (do ((display-info (pop *display-infos*)
				      (pop *display-infos*)))
		       ((null display-info))
		     (remove-display-of-object display-info)))))
	     (setq disembodied-display-infos *display-infos*))
	   (dolist (display-info (reverse disembodied-display-infos))
	     (push display-info *display-infos*))
	   *inspect-result*))
	(*display-infos*
	 (inspect-init)
	 (let ((*inspect-result* nil)
	       (*can-quit* t)
	       (*can-proceed* t))
	   (catch 'inspect-proceed
	     (catch 'inspect-exit
	       (loop (system:serve-event))))
	   *inspect-result*))
	(t (error "No object supplied for inspection and no previous ~
		   inspection object exists."))))
@


1.13
log
@Use pcl::class-of instead of pcl:class-of, because pcl's class-of is no
longer exported.
@
text
@a5 2
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@@cs.cmu.edu.
d8 1
a8 1
  "$Header: inspect.lisp,v 1.12 93/02/26 08:25:39 wlott Locked $")
@


1.12
log
@new structure branch & tuning, see new_struct
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.11.1.2 93/01/23 14:22:24 ram Exp $")
d1513 1
a1513 1
  (let ((class (pcl:class-of object)))
@


1.11
log
@Changed PLAN-DISPLAY-OBJECT to use WITH-SLOTS instead of accessors, since those
accessors don't seem to exist anymore.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.10 92/02/24 01:29:10 ram Locked $")
d1130 1
a1130 1
    (structure (plan-display-structure object))
d1145 1
a1145 1
      (structure (replan-display-structure plan object))
d1371 1
a1371 3
  (if (structurep object)
      (structure-ref object index)
      (aref object index)))
d1373 1
a1373 3
  (if (structurep object)
      (setf (structure-ref object index) new)
      (setf (aref object index) new)))
d1481 2
a1482 3

  (let* ((dd (info type defined-structure-info (structure-ref object 0)))
	 (dsds (c::dd-slots dd)))
d1486 1
a1486 1
				     (symbol-name (c::dd-name dd))
d1491 13
a1503 4
	 (push (make-slot-item (c::dsd-%name dsd)
			       (make-object-item
				(structure-ref object (c::dsd-index dsd))
				object (c::dsd-index dsd) 'vref 'vset))
@


1.11.1.1
log
@new structure hacks
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.11 92/07/16 18:57:10 ram Locked $")
d1371 3
a1373 1
  (aref object index))
d1375 3
a1377 1
  (setf (aref object index) new))
d1485 3
a1487 2
  (let* ((dd (layout-info (%instance-layout object)))
	 (dsds (dd-slots dd)))
d1491 1
a1491 1
				     (symbol-name (dd-name dd))
d1496 4
a1499 13
	 (push (make-slot-item
		(dsd-%name dsd)
		(make-object-item
		 (structure-ref object (dsd-index dsd))
		 object (dsd-index dsd)
		 #'(lambda (str ignore)
		     (declare (ignore ignore))
		     (funcall (fdefinition (dsd-accessor dsd))
			      str))
		 #'(lambda (str ignore val)
		     (declare (ignore ignore))
		     (funcall (fdefinition `(setf ,(dsd-accessor dsd)))
			      val str))))
@


1.11.1.2
log
@New structure hax.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.11.1.1 93/01/15 15:27:58 ram Locked $")
d1130 1
a1130 1
    (structure-object (plan-display-structure object))
d1145 1
a1145 1
      (structure-object (replan-display-structure plan object))
d1494 1
a1494 1
		 (funcall (fdefinition (dsd-accessor dsd)) object)
@


1.10
log
@Changed %primitive set-package to %set-symbol-package.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.9 91/10/22 16:17:37 wlott Locked $")
d1519 19
a1537 18
	 (let* ((slot (pcl::slotd-name slotd))
		(item (make-slot-item (prin1-to-string slot)
				      (make-object*-item
				       "Unbound"
				       (if (pcl:slot-boundp object slot)
					 (pcl:slot-value object slot))
				       (pcl:slot-boundp object slot)
				       object
				       slot
				       'ref-slot
				       'set-slot))))
	   (case (pcl::slotd-allocation slotd)
	     (:instance (push item instance-slots))
	     (:class (push item class-slots))
	     (otherwise
	      (setf (slot-item-name item)
		    (format nil "~S [~S]" slot (pcl::slotd-allocation slotd)))
	      (push item other-slots)))))
@


1.9
log
@Changed font specs to use point size instead of pixel size so that they will
work on 100dpi devices.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.8 91/08/30 17:33:57 ram Locked $")
d1608 1
a1608 1
  (lisp::%primitive set-package object new))
@


1.8
log
@Replaced absolute pathnames with references to library:.  Moved the help file
to library:.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.7 91/05/21 18:35:16 ram Locked $")
d103 1
a103 1
(defparameter header-font-name "*-courier-bold-r-normal--12-*")
d106 1
a106 1
(defparameter entry-font-name "*-courier-medium-r-normal--12-*")
d109 1
a109 1
(defparameter italic-font-name "*-courier-medium-o-normal--12-*")
@


1.7
log
@Changed boxifying back to use the boole-1, boole-c1 functions.  I think the
change was necessary on the pmax because the pmax CLX was broken.  Either that,
or neither one is right for both machines.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.6 91/05/15 16:29:38 ram Locked $")
a101 3
(defparameter lisp-fonts-pathnames
  '("/usr/misc/.cmucl/lib/fonts/"
    "/afs/cs/misc/cmucl/@@sys/alpha/lib/fonts/"))
d117 1
a117 1
(defparameter cursor-name "/usr/misc/.cmucl/lib/inspect11.cursor")
d119 1
a119 1
(defparameter cursor-d-name "/usr/misc/.cmucl/lib/inspect11-d.cursor")
d121 1
a121 1
(defparameter cursor-s-name "/usr/misc/.cmucl/lib/inspect11-s.cursor")
d130 1
a130 1
(defparameter help-file-pathname "/usr/misc/.cmucl/doc/inspector.help")
d243 5
a247 1
    (ext:carefully-add-font-paths *display* lisp-fonts-pathnames)
@


1.6
log
@Changed to use standard fonts (courier) and to generally work under the
new-compiler system.  Also, made the help window bigger.  For some reason,
boole-c1 doesn't seem to be having the expected effect (at least with the
ds5000 server).  I changed draw-box to use boole-set and boole-clr, but
invert-pixmap (and hence inversion of scrollbar buttons) doesn't work.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.5 91/02/14 18:46:15 ram Locked $")
d695 1
a695 1
    (boxify-item item boole-set)))
d698 1
a698 1
  (boxify-item item boole-clr))
@


1.5
log
@Merged systems-work sources as of this date.  The main change was
fixing this to use key events.
@
text
@d10 1
a10 1
  "$Header: inspect.lisp,v 1.4 91/02/08 13:33:13 ram Locked $")
d37 1
a37 1
(in-package "INSPECT" :use '("LISP" "KERNEL"))
d103 2
a104 2
  '("/usr/misc/.lisp/lib/fonts/"
    "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/"))
d106 1
a106 1
(defparameter header-font-name "inspect11-header")
d109 1
a109 1
(defparameter entry-font-name "8x13")
d112 1
a112 1
(defparameter italic-font-name "inspect11-italic")
d120 1
a120 1
(defparameter cursor-name "/usr/misc/.lisp/lib/inspect11.cursor")
d122 1
a122 1
(defparameter cursor-d-name "/usr/misc/.lisp/lib/inspect11-d.cursor")
d124 1
a124 1
(defparameter cursor-s-name "/usr/misc/.lisp/lib/inspect11-s.cursor")
d133 1
a133 1
(defparameter help-file-pathname "/usr/misc/.lisp/doc/inspector.help")
d366 7
a372 3
(defconstant important-xevents
  '(:key-press :button-press :exposure :pointer-motion
	       :enter-window :leave-window))
a373 2
(defconstant important-xevents-mask
  (apply #'xlib:make-event-mask important-xevents))
a374 1

d571 4
a574 1
  (format stream "#<~S>" (type-of item)))
a575 1

d695 1
a695 1
    (boxify-item item boole-1)))
d698 1
a698 1
  (boxify-item item boole-c1))
d1128 1
a1128 1
    (clos::object (plan-display-object object))
d1143 1
a1143 1
      (clos::object (replan-display-object plan object))
d1370 3
a1372 1
  (aref object index))
d1374 3
a1376 1
  (setf (aref object index) new))
d1497 1
a1497 1
				(svref object (c::dsd-index dsd))
d1508 1
a1508 1
  (let ((class (clos:class-of object)))
d1512 1
a1512 1
				     (clos:class-name class)
d1515 1
a1515 1
     (let ((slotds (clos::slots-to-inspect class object))
d1518 1
a1518 1
	 (let* ((slot (clos::slotd-name slotd))
d1522 3
a1524 3
				       (if (clos:slot-boundp object slot)
					 (clos:slot-value object slot))
				       (clos:slot-boundp object slot)
d1529 1
a1529 1
	   (case (clos::slotd-allocation slotd)
d1534 1
a1534 1
		    (format nil "~S [~S]" slot (clos::slotd-allocation slotd)))
d1550 2
a1551 2
  (if (clos:slot-boundp object slot)
    (values (clos:slot-value object slot) t)
d1555 1
a1555 1
  (setf (clos:slot-value object slot) val))
d1616 2
d1623 2
d1816 7
a1822 5
	 (with-open-file (stream help-file-pathname :direction :input)
	   (new-plan-in-new-display
	    nil
	    (plan-display-text nil (list (make-string-item "Help" *header-font*))
			       stream))))
d1838 1
@


1.4
log
@New file header with RCS header FILE-COMMENT.
@
text
@d10 1
a10 1
  "$Header: $")
d37 3
a39 2
(in-package "INSPECT" :use '("LISP"))
(export '(show-object remove-object-display remove-all-displays))
a40 3
;;; Squelch the compiler
(proclaim '(declaration values))

d383 1
a383 1
		 (ext:translate-character display code state))
d387 1
a387 1
		 (ext:translate-mouse-character code state event-key))
d559 1
a559 1
  (mouse-handler 'nothing-mouse-handler) ; Takes self, display, character
d1477 2
a1478 1
  (let* ((dd (info type defined-structure-info (svref object 0)))
d1672 9
a1680 7
	(xlib:set-standard-properties window
				      :name "Inspector Window"
				      :icon-name "Inspector Display"
				      :resource-name "Inspector"
				      :x x :y y :width width :height height
				      :min-width width :min-height height
				      :width-inc nil :height-inc nil)
d1794 4
a1797 5
(defun do-command (display-info character)
  (if *do-command*
      (funcall *do-command* display-info character)
      (case character
	((#\d #\D)
d1804 1
a1804 1
	((#\h #\H #\?)
d1810 1
a1810 1
	((#\m #\M)
d1820 1
a1820 1
			   ((char= character #\m)
d1831 1
a1831 1
	((#\q #\Q)
d1834 1
a1834 1
	((#\p #\P)
d1837 1
a1837 1
	((#\r #\R)
d1840 1
a1840 1
	((#\u #\U)
d1849 6
a1854 2
	((#\leftdown #\middledown #\rightdown
		     #\super-leftdown #\super-middledown #\super-rightdown)
d1857 1
a1857 1
		    *current-item* display-info character))))))
d1894 1
a1894 1
(defun track-for-do-command (display-info character)
d1896 2
a1897 2
  (case character
    ((#\q #\Q)
d1900 3
a1902 1
    ((#\leftdown #\middledown #\rightdown)
d1918 2
a1919 2
(defun nothing-mouse-handler (self display-info character)
  (declare (ignore self display-info character))
d1922 3
a1924 3
(defun mouse-object-item (self display-info character)
  (case character
    (#\leftdown
d1930 1
a1930 1
    (#\rightdown
d1933 1
a1933 1
    (#\middledown
d1937 1
a1937 1
    (#\super-middledown
d1942 1
a1942 1
(defun mouse-object*-item (self display-info character)
d1944 1
a1944 1
    (mouse-object-item self display-info character)))
d1946 1
a1946 1
(defun mouse-scrollbar-item (self display-info character)
d1951 1
a1951 1
	   (incf new-first (if (eql character #\rightdown)
d1955 1
a1955 1
	   (decf new-first (if (eql character #\rightdown)
d2001 2
d2006 16
a2021 5
(defun inspect (&optional (object nil object-p))
  "This function allows the user to interactively exam Lisp objects.  Invoking
   it with no arguments resumes inspection of items left active from previous
   exits."
  (cond ((not (assoc :display ext:*environment-list*))
d2023 4
d2059 3
a2061 1
	   *inspect-result*))))
@


1.3
log
@.../code/inspect.lisp, 31-Jan-90 23:59:51, Edit by Wlott.
  Found (and fixed) a few more references to SYSTEM:SERVER.

.../systems-work/code/inspect.lisp, 16-Jan-90 13:33:20, Edit by William.
  Added rudimentary support for PCL objects.

@
text
@d4 8
a11 4
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@@CMUC). 
@


1.2
log
@Changed PLAN-DISPLAY-STRUCTURE to use INFO TYPE DEFINED-STRUCTURE-INFO.
@
text
@d1123 1
d1138 1
d1497 56
d1860 5
a1864 4
;;; TRACK-FOR loops over SYSTEM:SERVER waiting for some event handler to throw
;;; to this CATCH tag.  Since any such handler throws past SYSTEM:SERVER, and
;;; therefore, past the CLX event dispatching form in INSPECTOR-EVENT-HANDLER,
;;; it is that handler's responsibility to discard its event.
d1876 1
a1876 1
	    (loop (system:server)))
d2013 1
a2013 1
		       (loop (system:server)))
d2031 1
a2031 1
	       (loop (system:server))))
@


1.1
log
@Initial revision
@
text
@d1473 1
a1473 1
  (let* ((dd (info type structure-info (svref object 0)))
@