home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / inspect.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  70.0 KB  |  2,078 lines
  1. ;;; -*- Mode: Lisp; Package: INSPECT; Log:code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: inspect.lisp,v 1.11 92/07/16 18:57:10 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; An inspector for CMU Common Lisp.
  15. ;;; 
  16. ;;; Written by Skef Wholey.
  17. ;;; Ported to CLX by Christopher Hoover with minor tweaks by Bill Chiles.
  18. ;;;
  19. ;;; Each Lisp object is displayed in its own X window, and components of
  20. ;;; each object are "mouse sensitive" items that may be selected for
  21. ;;; further investigation.  This is all done with a kind of home-made object
  22. ;;; system, based on Defstruct.
  23. ;;;
  24. ;;; NOTE: due to porting this code between X10 and X11, there is a gross
  25. ;;; confusion in the code based on the term "display".  Sometimes it means a
  26. ;;; CLX display structure, and sometimes it means a disp structure defined in
  27. ;;; this file.  This disp structure also uses the conc-name "display-".
  28. ;;; AN ATTEMPT TO CORRECT THIS HAS BEEN MADE BY RENAMING SUCH THINGS TO
  29. ;;; DISPLAY-INFO, BUT PROBLEMS STILL EXIST.  There is a DISPLAY-ITEM-DISPLAY
  30. ;;; which is neither a CLX display or the display of an object; it is a method
  31. ;;; which displays the item.
  32. ;;;
  33.  
  34. (in-package "LISP")
  35. (export 'inspect)
  36.  
  37. (in-package "INSPECT" :use '("LISP" "KERNEL" "EXTENSIONS"))
  38. (export '(show-object remove-object-display remove-all-displays
  39.               *interface-style*))
  40.  
  41.  
  42. ;;; Parameters and stuff.
  43.  
  44. ;;; CLX specials
  45.  
  46. (defvar *display* nil)
  47. (defvar *screen* nil)
  48. (defvar *root* nil)
  49. (defvar *gcontext* nil)
  50. (defvar *black-pixel* nil)
  51. (defvar *white-pixel* nil)
  52.  
  53. ;;; Inspect-Length is the number of components that will be displayed in a
  54. ;;; window at any one time.  If an object has more than Inspect-Length 
  55. ;;; components, we generally put it in a scrolling window.  Inspect-Level
  56. ;;; might someday correspond to Print-Level, controlling the amount of
  57. ;;; detail and mouse-sensitivity we get inside components, but for now
  58. ;;; it's ignored.
  59.  
  60. (defparameter inspect-length 10)
  61. (defparameter inspect-level 1)
  62.  
  63.  
  64. ;;; Inspect-Print-Level and Inspect-Print-Length are used by IPrin1-To-String
  65. ;;; to generate the textual representation of components.
  66.  
  67. (defparameter inspect-print-length 10)
  68. (defparameter inspect-print-level 3)
  69.  
  70. (defun iprin1-to-string (object)
  71.   (let ((*print-length* inspect-print-length)
  72.     (*print-level* inspect-print-level)
  73.     (*print-pretty* nil))
  74.     (prin1-to-string object)))
  75.  
  76.  
  77. ;;; Inspect-Line-Length is a hack used in only one place that we should get
  78. ;;; rid of someday.
  79.  
  80. (defparameter inspect-line-length 80)
  81.  
  82.  
  83. ;;; Setting up fonts and cursors and stuff.
  84.  
  85. ;;; We use Font structures to keep stuff like the character height and width
  86. ;;; of a font around for quick and easy size calculations.  For variable width
  87. ;;; fonts, the Width slot will be Nil.
  88.  
  89. (defstruct (font (:constructor make-font (name font height ascent width)))
  90.   name
  91.   font
  92.   height
  93.   ascent
  94.   width)
  95.  
  96.  
  97. ;;; The *Header-Font* is a big font usually used for displaying stuff in
  98. ;;; the header portion of an object display.  *Entry-Font* is used as the
  99. ;;; main "body font" for an object, and *Italic-Font* is used for special
  100. ;;; stuff.
  101.  
  102.  
  103. (defparameter header-font-name "*-courier-bold-r-normal--*-120-*")
  104. (defvar *header-font*)
  105.  
  106. (defparameter entry-font-name "*-courier-medium-r-normal--*-120-*")
  107. (defvar *entry-font*)
  108.  
  109. (defparameter italic-font-name "*-courier-medium-o-normal--*-120-*")
  110. (defvar *italic-font*)
  111.  
  112. ;;; The *Cursor* is a normal arrow thing used most of the time.  During
  113. ;;; modification operations, we change the cursor to *Cursor-D* (while the
  114. ;;; destination for the modification is being chosen) and *Cursor-S* (while
  115. ;;; the source is being chosen).
  116.  
  117. (defparameter cursor-name "library:inspect11.cursor")
  118. (defvar *cursor*)
  119. (defparameter cursor-d-name "library:inspect11-d.cursor")
  120. (defvar *cursor-d*)
  121. (defparameter cursor-s-name "library:inspect11-s.cursor")
  122. (defvar *cursor-s*)
  123.  
  124.  
  125. ;;; This file contains the help message for the inspector.  The text in the
  126. ;;; file must not extend past the 72nd column, and any initial whitespace on
  127. ;;; a line must be built on the space character only.  The window that displays
  128. ;;; this text is too small in height for easy reading of this text.
  129. ;;;
  130. (defparameter help-file-pathname "library:inspector.help")
  131.  
  132.  
  133.  
  134. ;;;; CLX stuff
  135.  
  136. ;;; The arrow bitmaps are used inside scrollbars.
  137.  
  138. (defvar *up-arrow*)
  139. (defvar *down-arrow*)
  140. (defvar *up-arrow-i*)
  141. (defvar *down-arrow-i*)
  142.  
  143. (defparameter arrow-bits
  144.   '(#*0000000000000000
  145.     #*0111111111111110
  146.     #*0100000000000010
  147.     #*0100000110000010
  148.     #*0100001111000010
  149.     #*0100011111100010
  150.     #*0100111111110010
  151.     #*0101111111111010
  152.     #*0100001111000010
  153.     #*0100001111000010
  154.     #*0100001111000010
  155.     #*0100001111000010
  156.     #*0100001111000010
  157.     #*0100000000000010
  158.     #*0111111111111110
  159.     #*0000000000000000))
  160.  
  161.  
  162. ;;; Font and cursor support
  163.  
  164. (defun open-font (name)
  165.   (let* ((font (xlib:open-font *display* name))
  166.      (max-width (xlib:max-char-width font))
  167.      (min-width (xlib:min-char-width font))
  168.      (width (if (= max-width min-width) max-width nil))
  169.      (ascent (xlib:max-char-ascent font))
  170.      (height (+ (xlib:max-char-descent font) ascent)))
  171.     (make-font name font height ascent width)))
  172.  
  173. (defun get-cursor-pixmap-from-file (name)
  174.   (let ((pathname (probe-file name)))
  175.     (if pathname
  176.     (let* ((image (xlib:read-bitmap-file pathname))
  177.            (pixmap (xlib:create-pixmap :width 16 :height 16
  178.                        :depth 1 :drawable *root*))
  179.            (gc (xlib:create-gcontext :drawable pixmap
  180.                      :function boole-1
  181.                      :foreground *black-pixel*
  182.                      :background *white-pixel*)))
  183.       (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
  184.       (xlib:free-gcontext gc)
  185.       (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image)))
  186.     (values nil nil nil))))
  187.  
  188. (defun open-cursor (name)
  189.   (multiple-value-bind
  190.       (cursor-pixmap cursor-x-hot cursor-y-hot)
  191.       (get-cursor-pixmap-from-file name)
  192.     (multiple-value-bind
  193.     (mask-pixmap mask-x-hot mask-y-hot)
  194.     (get-cursor-pixmap-from-file (make-pathname :type "mask" :defaults name))
  195.       (declare (ignore mask-x-hot mask-y-hot))
  196.       (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
  197.          (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
  198.          (cursor (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
  199.                      :x cursor-x-hot :y cursor-y-hot
  200.                      :foreground black :background white)))
  201.     (xlib:free-pixmap mask-pixmap)
  202.     (xlib:free-pixmap cursor-pixmap)
  203.     cursor))))
  204.  
  205. (defun bitvec-list-to-pixmap (bvl width height)
  206.   (let* ((image (apply #'xlib:bitmap-image bvl))
  207.      (pixmap (xlib:create-pixmap :width width :height height
  208.                      :drawable *root*
  209.                      :depth (xlib:screen-root-depth *screen*)))
  210.      (gc (xlib:create-gcontext :drawable pixmap
  211.                    :function boole-1
  212.                    :foreground *black-pixel*
  213.                    :background *white-pixel*)))
  214.     (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16 :bitmap-p t)
  215.     (xlib:free-gcontext gc)
  216.     pixmap))
  217.  
  218. (defun invert-pixmap (pixmap)
  219.   (let* ((width (xlib:drawable-width pixmap))
  220.      (height (xlib:drawable-height pixmap))
  221.      (inv-pixmap (xlib:create-pixmap :width width :height height
  222.                      :drawable *root*
  223.                      :depth (xlib:screen-root-depth *screen*)))
  224.      (gc (xlib:create-gcontext :drawable inv-pixmap
  225.                    :function boole-c1
  226.                    :foreground *black-pixel*
  227.                    :background *white-pixel*)))
  228.     (xlib:copy-area pixmap gc 0 0 width height inv-pixmap 0 0)
  229.     (xlib:free-gcontext gc)
  230.     inv-pixmap))
  231.  
  232.  
  233. ;;;; Inspect-Init
  234.  
  235. ;;; Inspect-Init sets all this stuff up, using *Inspect-Initialized* to
  236. ;;; know when it's already been done.
  237.  
  238. (defvar *inspect-initialized* nil)
  239.  
  240. (defun inspect-init ()
  241.   (unless *inspect-initialized*
  242.     (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
  243.     (ext:carefully-add-font-paths
  244.      *display*
  245.      (mapcar #'(lambda (x)
  246.          (concatenate 'string (namestring x) "fonts/"))
  247.          (search-list "library:")))
  248.     (setq *root* (xlib:screen-root *screen*))
  249.     (setq *black-pixel* (xlib:screen-black-pixel *screen*))
  250.     (setq *white-pixel* (xlib:screen-white-pixel *screen*))
  251.     (setq *gcontext* (xlib:create-gcontext :drawable *root* :function boole-1
  252.                        :foreground *black-pixel*
  253.                        :background *white-pixel*))
  254.     (setq *cursor* (open-cursor cursor-name))
  255.     (setq *cursor-d* (open-cursor cursor-d-name))
  256.     (setq *cursor-s* (open-cursor cursor-s-name))
  257.     (setq *header-font* (open-font header-font-name))
  258.     (setq *entry-font* (open-font entry-font-name))
  259.     (setq *italic-font* (open-font italic-font-name))
  260.     (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16))
  261.     (setq *up-arrow-i* (invert-pixmap *up-arrow*))
  262.     (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16))
  263.     (setq *down-arrow-i* (invert-pixmap *down-arrow*))
  264.     (ext:enable-clx-event-handling *display* 'inspector-event-handler)
  265.     (setq *inspect-initialized* t)))
  266.  
  267. #|
  268. ;;; For debugging...
  269. ;;; 
  270. (defun inspect-reinit (&optional (host "unix:0.0"))
  271.   (let ((win nil))
  272.     (setq *inspect-initialized* nil)
  273.     (when *display*
  274.       (ext:disable-clx-event-handling *display*)
  275.       (xlib:close-display *display*)))
  276.     (unwind-protect
  277.     (progn
  278.       (multiple-value-setq
  279.           (*display* *screen*)
  280.         (ext:open-clx-display host))
  281.       (setf (xlib:display-after-function *display*)
  282.         #'xlib:display-finish-output)
  283.       (setq *root* (xlib:screen-root *screen*))
  284.       (setq *black-pixel* (xlib:screen-black-pixel *screen*))
  285.       (setq *white-pixel* (xlib:screen-white-pixel *screen*))
  286.       (setq *gcontext* (xlib:create-gcontext :drawable *root*
  287.                          :function boole-1
  288.                          :foreground *black-pixel*
  289.                          :background *white-pixel*))
  290.       (setq *cursor* (open-cursor cursor-name))
  291.       (setq *cursor-d* (open-cursor cursor-d-name))
  292.       (setq *cursor-s* (open-cursor cursor-s-name))
  293.       (setq *header-font* (open-font header-font-name))
  294.       (setq *entry-font* (open-font entry-font-name))
  295.       (setq *italic-font* (open-font italic-font-name))
  296.       (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16))
  297.       (setq *up-arrow-i* (invert-pixmap *up-arrow*))
  298.       (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16))
  299.       (setq *down-arrow-i* (invert-pixmap *down-arrow*))
  300.       (setf (xlib:display-after-function *display*) nil)
  301.       (setf win t))
  302.       (cond (win
  303.          (ext:enable-clx-event-handling *display* 'inspector-event-handler)
  304.          (setq *inspect-initialized* t))
  305.         (*display*
  306.          (xlib:close-display *display*))))))
  307. |#
  308.  
  309.  
  310. ;;; More X Stuff
  311.  
  312. ;;; We use display-info structures to associate objects with their graphical
  313. ;;; images (Display-Items, see below), the X windows that they're displayed in,
  314. ;;; and maybe even a user-supplied Name for the whole thing.
  315.  
  316. (defstruct (display-info
  317.         (:constructor make-display-info (name object display-item window)))
  318.   name
  319.   object
  320.   display-item
  321.   window
  322.   (stack nil))
  323.  
  324. ;;; *display-infos* is a list of all the live displays of objects.
  325. ;;;
  326. (defvar *display-infos* nil)
  327.  
  328.  
  329. ;;; CLX window to display-info structure mapping.
  330. ;;;
  331. (defvar *windows-to-displays* (make-hash-table :test #'eq))
  332.  
  333. (defun add-window-display-info-mapping (window display-info)
  334.   (setf (gethash window *windows-to-displays*) display-info))
  335.  
  336. (defun delete-window-display-info-mapping (window)
  337.   (remhash window *windows-to-displays*))
  338.  
  339. (defun map-window-to-display-info (window)
  340.   (multiple-value-bind (display-info found-p)
  341.                (gethash window *windows-to-displays*)
  342.     (unless found-p (error "No such window as ~S in mapping!" window))
  343.     display-info))
  344.  
  345.  
  346.  
  347. ;;; *Tracking-Mode* is a kind of hack used so things know what to do
  348. ;;; during modify operations.  If it's :Source, only objects that are really
  349. ;;; there will be selectable.  If it's :Destination, objects that aren't
  350. ;;; necessarily really there (like the values of unbound symbols) will be
  351. ;;; selectable.
  352.  
  353. (defvar *tracking-mode* :source)
  354.  
  355.  
  356. ;;; *Mouse-X* and *Mouse-Y* are a good approximation of where the mouse is
  357. ;;; in the window that the mouse is in.
  358.  
  359. (defvar *mouse-x* 0)
  360. (defvar *mouse-y* 0)
  361.  
  362.  
  363. ;;;; Event Handling
  364.  
  365. ;;; We're interested in these events:
  366.  
  367. (eval-when (compile load eval)
  368.   (defconstant important-xevents
  369.     '(:key-press :button-press :exposure :pointer-motion
  370.          :enter-window :leave-window))
  371.   
  372.   (defconstant important-xevents-mask
  373.     (apply #'xlib:make-event-mask important-xevents)))
  374.  
  375.  
  376. (defun inspector-event-handler (display)
  377.   (xlib:event-case (display :discard-p t :force-output-p t :timeout 0)
  378.     ((:exposure) (event-window count)
  379.      (when (zerop count)
  380.        (redisplay-item
  381.     (display-info-display-item (map-window-to-display-info event-window))))
  382.      t)
  383.     ((:key-press) (event-window state code)
  384.      (do-command (map-window-to-display-info event-window)
  385.          (ext:translate-key-event display code state))
  386.      t)
  387.     ((:button-press :button-release) (event-key event-window state code)
  388.      (do-command (map-window-to-display-info event-window)
  389.          (ext:translate-mouse-key-event code state event-key))
  390.      t)
  391.     ((:enter-notify :motion-notify) (event-window x y)
  392.      (cond ((xlib:event-listen display)
  393.         ;; if there are other things in the queue, blow this event off...
  394.         nil)
  395.        (t
  396.         (setf *mouse-x* x)
  397.         (setf *mouse-y* y)
  398.         (track-mouse (display-info-display-item
  399.               (map-window-to-display-info event-window))
  400.              x y)
  401.         t)))
  402.     ((:leave-notify) (event-window)
  403.      (track-mouse (display-info-display-item
  404.            (map-window-to-display-info event-window))
  405.           -1 -1)
  406.      t)
  407.     ((:no-exposure) ()
  408.      ;; just ignore this one
  409.      t)
  410.     (t (event-key)
  411.        (warn "Inspector received unexpected event, ~S, recieved." event-key)
  412.        t)))
  413.  
  414. #|
  415.  
  416. ;;; Some debugging code...
  417.  
  418.     (xlib:event-cond (display :timeout 0 :peek-p t)
  419.              (t (event-key)
  420.             (unless (eq event-key :motion-notify)
  421.               (format t "Event received: ~S~%" event-key))))
  422.  
  423. (defun discard-event-on-window (display window type)
  424.   (loop
  425.     (unless (xlib:process-event display :timeout 0
  426.           :handler #'(lambda (&key event-window event-type &allow-other-keys)
  427.                (and (eq event-window window)
  428.                 (eq event-type type))))
  429.       (return))))
  430.  
  431. |#
  432.     
  433.  
  434. ;;;; Yet more X stuff.
  435.  
  436. ;;; NEXT-WINDOW-POSITION currently uses a very dumb heuristic to decide where
  437. ;;; the next inspector window ought to go.  If there aren't any windows, it
  438. ;;; puts the display of an object in the upper left hand corner.  Otherwise,
  439. ;;; it'll put it underneath the last one created.  When putting the new
  440. ;;; window below the last one, if it should extent below the bottom of the
  441. ;;; screen, we position it to just fit on the bottom.  Thus, all future windows
  442. ;;; created in this fashion will "pile up" on the bottom of the screen.
  443. ;;;
  444. (defun next-window-position (width height)
  445.   (declare (ignore width))
  446.   (if *display-infos*
  447.       (let ((window (display-info-window (car *display-infos*))))
  448.     (xlib:with-state (window)
  449.       (let ((drawable-x (xlib:drawable-x window))
  450.         (drawable-y (xlib:drawable-y window))
  451.         (drawable-height (xlib:drawable-height window))
  452.         (border-width (xlib:drawable-border-width window)))
  453.         (declare (fixnum drawable-y drawable-height border-width))
  454.         (multiple-value-bind (children parent root) (xlib:query-tree window)
  455.           (declare (ignore children))
  456.           (let ((root-height (xlib:drawable-height root)))
  457.         (declare (fixnum root-height))
  458.         (multiple-value-bind
  459.             (new-x new-y)
  460.             (if (eq parent root)
  461.             (values drawable-x (+ drawable-y drawable-height
  462.                           (* 2 border-width)))
  463.             ;; Deal with reparented windows...
  464.             (multiple-value-bind (root-x root-y)
  465.                          (xlib:translate-coordinates
  466.                           parent drawable-x drawable-y root)
  467.               (declare (fixnum root-y))
  468.               (values root-x (+ root-y drawable-height
  469.                         (* 2 border-width)))))
  470.           (declare (fixnum new-y))
  471.           (values new-x
  472.               (if (> (+ new-y height border-width) root-height)
  473.                   (- root-height height border-width)
  474.                   new-y))))))))
  475.       (values 2 2)))
  476.  
  477. ;;; Max-Window-Width is used to constrain the width of our displays.
  478.  
  479. (defparameter max-window-width 700)
  480.  
  481.  
  482. ;;; Border is the number of pixels between an object display and the box
  483. ;;; we draw around it.  VSP is the number of pixels we leave between lines
  484. ;;; of text.  (We should put VSP in the fonts structure sometime so we can
  485. ;;; have font-specific vertical spacing.)
  486.  
  487. (defparameter border 3)
  488. (defparameter vsp 2)
  489.  
  490.  
  491. ;;; *X-Constraint* is used by Disp-String to truncate long strings so that
  492. ;;; they stay inside windows of reasonable width.
  493.  
  494. (defvar *x-constraint* nil)
  495.  
  496.  
  497. ;;; Disp-String draws a string, trying to constrain it to not run beyond the
  498. ;;; *X-Constraint*.  For variable width fonts, we can only guess about the
  499. ;;; right length...
  500.  
  501. (defun disp-string (window x y string disp-font)
  502.   (declare (simple-string string))
  503.   (let ((font (font-font disp-font))
  504.     (font-width (font-width disp-font))
  505.     (font-height (font-height disp-font))
  506.     (length (length string))
  507.     (max-width (if *x-constraint* (- *x-constraint* x) max-window-width)))
  508.     (cond (font-width
  509.        ;; fixed width font
  510.        (let ((end (if (<= (* length font-width) max-width)
  511.               length
  512.               (max 0 (truncate max-width font-width)))))
  513.          (when window
  514.            (xlib:with-gcontext (*gcontext* :font font)
  515.          (xlib:draw-image-glyphs window *gcontext*
  516.                      x (+ y (font-ascent disp-font))
  517.                      string :end end)))
  518.          (values (* end font-width) (+ font-height vsp))))
  519.       (t
  520.        ;; this is hackish...
  521.        (multiple-value-bind
  522.            (end width)
  523.            (do* ((index length (1- index))
  524.              (width (xlib:text-width font string :end index)
  525.                 (xlib:text-width font string :end index)))
  526.             ((or (= index 0) (<= width max-width))
  527.              (values index width)))
  528.          (when window
  529.            (xlib:with-gcontext (*gcontext* :font font)
  530.          (xlib:draw-image-glyphs window *gcontext*
  531.                      x (+ y (font-ascent disp-font))
  532.                      string :end end)))
  533.          (values width (+ font-height vsp)))))))
  534.  
  535.  
  536. ;;;; Draw-Bitmap, Draw-Box, and Draw-Block
  537.  
  538. (defun draw-bitmap (window x y pixmap)
  539.   (xlib:copy-area pixmap *gcontext* 0 0 16 16 window x y))
  540.  
  541. (defun draw-box (window x1 y1 x2 y2)
  542.   (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1)))
  543.  
  544. (defun draw-block (window x1 y1 x2 y2)
  545.   (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1) t))
  546.  
  547.  
  548. ;;;; Display-Item
  549.  
  550. ;;; Display-Items are objects with methods to display themselves, track the
  551. ;;; mouse inside their boundries, handle mouse clicks on themselves, and so
  552. ;;; on.  Everything we put up on the screen is backed in some way by a
  553. ;;; Display-Item.  These are the components of the total display of an object
  554. ;;; as described in a display-info structure.
  555. ;;;
  556. (defstruct (display-item
  557.         (:print-function print-display-item))
  558.   display            ; Takes self, window, x, y
  559.   (tracker 'nothing-tracker)    ; Takes self, x, y
  560.   (untracker 'nothing-untracker); Takes self
  561.   (mouse-handler 'nothing-mouse-handler) ; Takes self, display, key-event
  562.   (walker 'nothing-walker)    ; Takes self, function to walk
  563.   window            ; Window and position and size once displayed
  564.   x
  565.   y
  566.   width
  567.   height
  568.   )
  569.  
  570. (defun print-display-item (item stream depth)
  571.   (declare (ignore depth))
  572.   (format stream "#<~S {~8,'0X}>" (type-of item)
  573.       #+cmu
  574.       (kernel:get-lisp-obj-address item)
  575.       #-cmu 0))
  576.  
  577. ;;; The *Current-Item* is the display item that is currently under the mouse,
  578. ;;; to the best of our knowledge, or Nil if the mouse isn't over an item that
  579. ;;; does anything with its Tracker method.
  580.  
  581. (defvar *current-item* nil)
  582.  
  583.  
  584. ;;; Display-Item invokes the Display method of an item to put it up on the
  585. ;;; specified window.  The window, position, and size are all set, and the
  586. ;;; size is returned.
  587.  
  588. (defun display-item (item window x y)
  589.   (setf (display-item-window item) window
  590.     (display-item-x item) x
  591.     (display-item-y item) y)
  592.   (multiple-value-bind
  593.       (width height)
  594.       (funcall (display-item-display item) item window x y)
  595.     (setf (display-item-width item) width)
  596.     (setf (display-item-height item) height)
  597.     (values width height)))
  598.  
  599. ;;; Redisplay-Item redraws an item (if, say, it's changed, or if its window
  600. ;;; has received an exposure event).  If the item is the *Current-Item*,
  601. ;;; we call its tracker method to make sure it gets highlighted if it's
  602. ;;; supposed to be.
  603.  
  604. (defun redisplay-item (item)
  605.   (when (display-item-window item)
  606.     (xlib:clear-area (display-item-window item)
  607.              :x (display-item-x item) :y (display-item-y item)
  608.              :width (display-item-width item)
  609.              :height (display-item-height item))
  610.     (multiple-value-bind
  611.     (width height)
  612.     (funcall (display-item-display item) item
  613.          (display-item-window item)
  614.          (display-item-x item) (display-item-y item))
  615.       (setf (display-item-width item) width)
  616.       (setf (display-item-height item) height))
  617.     (xlib:display-force-output *display*)
  618.     (when (and *current-item*
  619.            (eq (display-item-window *current-item*)
  620.            (display-item-window item)))
  621.       (track-mouse *current-item* *mouse-x* *mouse-y*))))
  622.  
  623. ;;; Size-Item uses the Display method to calculate the size of an item
  624. ;;; once displayed.  If the window supplied to Display-Item is Nil, all
  625. ;;; the size calculation will get done, but no graphical output will
  626. ;;; happen.
  627.  
  628. (defun size-item (item)
  629.   (if (display-item-width item)
  630.       (values (display-item-width item) (display-item-height item))
  631.       (display-item item nil 0 0)))
  632.  
  633.  
  634. ;;; Walk-Item calls the Walker method of the given Item.  Walk-Item-List
  635. ;;; is used by some methods to walk down a list of items they have inside
  636. ;;; themselves.
  637.  
  638. (defun walk-item (item function)
  639.   (funcall (display-item-walker item) item function))
  640.  
  641. (defun walk-item-list (list function)
  642.   (dolist (item list)
  643.     (when (display-item-p item)
  644.       (walk-item item function))))
  645.  
  646.  
  647. ;;; The Nothing-Walker is used by guys that don't have any object items
  648. ;;; inside them.
  649.  
  650. (defun nothing-walker (self function)
  651.   (declare (ignore self function)))
  652.  
  653.  
  654. ;;; Tracking and untracking.
  655.  
  656. ;;; Track-Item and Untrack-Item call the right methods of the given Item.
  657.  
  658. (defun track-item (item x y)
  659.   (funcall (display-item-tracker item) item x y))
  660.  
  661. (defun untrack-item (item)
  662.   (funcall (display-item-untracker item) item))
  663.  
  664. ;;; Update-Current-Item is used by trackers to figure out if an item
  665. ;;; is really under the mouse.  If it is, and it's not the same as the
  666. ;;; *Current-Item*, the *Current-Item* gets untracked.  If the mouse is
  667. ;;; inside the current item, Update-Current-Item returns T.
  668.  
  669. (defun update-current-item (item x y)
  670.   (let ((old-current *current-item*))
  671.     (if (and (<= (display-item-x item) x
  672.          (+ (display-item-x item) (display-item-width item)))
  673.          (<= (display-item-y item) y
  674.          (+ (display-item-y item) (display-item-height item))))
  675.     (setq *current-item* item)
  676.     (setq *current-item* nil))
  677.     (when (and old-current (not (eq *current-item* old-current)))
  678.       (untrack-item old-current)))
  679.   (eq item *current-item*))
  680.  
  681.  
  682. ;;; The Nothing-Tracker and Nothing-Untracker don't do much.
  683.  
  684. (defun nothing-tracker (item x y)
  685.   (update-current-item item x y))
  686.  
  687. (defun nothing-untracker (item)
  688.   (declare (ignore item)))
  689.  
  690.  
  691. ;;; The Boxifying-Tracker and Boxifying-Untracker highlight and unhighlight
  692. ;;; an item by drawing or erasing a box around the object.
  693.  
  694. (defun boxifying-tracker (item x y)
  695.   (when (update-current-item item x y)
  696.     (boxify-item item boole-1)))
  697.  
  698. (defun boxifying-untracker (item)
  699.   (boxify-item item boole-c1))
  700.  
  701. (defun boxify-item (item function)
  702.   (let ((x1 (display-item-x item))
  703.     (y1 (display-item-y item))
  704.     (width (display-item-width item))
  705.     (height (- (display-item-height item) 2))
  706.     (window (display-item-window item)))
  707.     (xlib:with-gcontext (*gcontext* :function function)
  708.       (xlib:draw-rectangle window *gcontext* x1 y1 width height))
  709.     (xlib:display-force-output *display*)))
  710.  
  711. ;;; Track-In-List tries to track inside of each item in the List.
  712.  
  713. (defun track-in-list (list x y)
  714.   (dolist (item list)
  715.     (when (display-item-p item)
  716.       (when (and (<= (display-item-x item) x
  717.              (+ (display-item-x item) (display-item-width item)))
  718.          (<= (display-item-y item) y
  719.              (+ (display-item-y item) (display-item-height item))))
  720.     (track-item item x y)
  721.     (return-from track-in-list nil))))
  722.   (when *current-item*
  723.     (untrack-item *current-item*)
  724.     (setq *current-item* nil)))
  725.  
  726. ;;;; Specialized Display-Item definitions.
  727.  
  728. ;;; Inspection-Items are used as the "top-level" items in the display of an
  729. ;;; object.  They've got a list of header items and a list of entry items.
  730. ;;;
  731. (defstruct (inspection-item
  732.         (:print-function print-display-item)
  733.         (:include display-item
  734.               (display 'display-inspection-item)
  735.               (tracker 'track-inspection-item)
  736.               (walker 'walk-inspection-item))
  737.         (:constructor make-inspection-item (objects headers entries)))
  738.   objects        ; Objects being inspected (for decaching)
  739.   headers        ; List of items in header, may be Nil
  740.   entries        ; List of items below header
  741.   )
  742.  
  743. ;;; Scrolling-Inspection-Items are used as the "top-level" of display of
  744. ;;; objects that have lots of components and so have to scroll.  In addition to
  745. ;;; headers and entries, they've got a scrollbar item and stuff so that the
  746. ;;; entries can lazily compute where they are and what they should display.
  747. ;;;
  748. (defstruct (scrolling-inspection-item
  749.         (:print-function print-display-item)
  750.         (:include inspection-item
  751.               (tracker 'track-scrolling-inspection-item))
  752.         (:constructor make-scrolling-inspection-item
  753.               (objects headers entries scrollbar)))
  754.   scrollbar        ; Scrollbar display item
  755.   set-next        ; To set next state
  756.   next            ; To get & increment next state
  757.   )
  758.  
  759. ;;; A Scrollbar-Item has buttons and a thumb bar and the stuff it needs to figure
  760. ;;; out whatever it needs to figure out.
  761.  
  762. (defstruct (scrollbar-item
  763.         (:print-function print-display-item)
  764.         (:include display-item
  765.               (display 'display-scrollbar-item)
  766.               (tracker 'track-scrollbar-item)
  767.               (untracker 'untrack-scrollbar-item)
  768.               (mouse-handler 'mouse-scrollbar-item))
  769.         (:constructor make-scrollbar-item
  770.               (first-index num-elements num-elements-displayed
  771.                next-element reset-index)))
  772.   scrollee        ; Item for which this guy's a scrollbar
  773.   bottom        ; Y coordinate of end (hack, hack)
  774.   active-button
  775.   first-index        ; Index of first thing to be displayed
  776.   next-element        ; Function to extract next element to be displayed
  777.   reset-index        ; Function to reset internal index for next-element
  778.   window-width        ; Max X for scrollees
  779.   bar-height        ; Height of bar in pixels
  780.   bar-top
  781.   bar-bottom
  782.   num-elements        ; Number of elements in scrollee
  783.   num-elements-displayed ; Number of elements displayed at once
  784.   )
  785.  
  786. ;;; Scrolling-Items are used as the entries in Scrolling-Inspection-Items.
  787. ;;; they know the scrollbar that moves them around so they can lazily do
  788. ;;; their stuff.
  789.  
  790. (defstruct (scrolling-item
  791.         (:print-function print-display-item)
  792.         (:include display-item
  793.               (display 'display-scrolling-item)
  794.               (tracker 'track-scrolling-item)
  795.               (walker 'walk-scrolling-item))
  796.         (:constructor make-scrolling-item (scrollbar item)))
  797.   scrollbar
  798.   item
  799.   )
  800.  
  801. ;;; String-Items just have a string of text and a font that it gets displayed in.
  802.  
  803. (defstruct (string-item
  804.         (:print-function print-display-item)
  805.         (:include display-item
  806.               (display 'display-string-item))
  807.         (:constructor make-string-item (string &optional (font *entry-font*))))
  808.   string        ; String to be displayed
  809.   font            ; Font in which to display it
  810.   )
  811.  
  812. ;;; Slot-Items have a string name for the slot (e.g., structure slot name or vector
  813. ;;; index) and an object item for the contents of the slot.  The Max-Name-Width
  814. ;;; is used so that all the slots in an inspection item can line their objects
  815. ;;; up nicely in a left-justified column.
  816.  
  817. (defstruct (slot-item
  818.         (:print-function print-display-item)
  819.         (:include display-item
  820.               (display 'display-slot-item)
  821.               (tracker 'track-slot-item)
  822.               (walker 'walk-slot-item))
  823.         (:constructor make-slot-item (name object)))
  824.   name            ; String name of slot
  825.   object        ; Display item for contents of slot
  826.   max-name-width    ; Length of longest slot name in structure
  827.   )
  828.  
  829. ;;; List-Items are used to display several things on the same line, one after
  830. ;;; the other.
  831.  
  832. (defstruct (list-item
  833.         (:print-function print-display-item)
  834.         (:include display-item
  835.               (display 'display-list-item)
  836.               (tracker 'track-list-item)
  837.               (walker 'walk-list-item))
  838.         (:constructor make-list-item (list)))
  839.   list            ; List of things to be displayed
  840.   )
  841.  
  842. ;;; Object-Items are used to display component Lisp objects.  They know where
  843. ;;; the object came from and how to get it again (for decaching) and how to
  844. ;;; change it (for modification).
  845.  
  846. (defstruct (object-item
  847.         (:print-function print-display-item)
  848.         (:include display-item
  849.               (display 'display-object-item)
  850.               (tracker 'boxifying-tracker)
  851.               (untracker 'boxifying-untracker)
  852.               (mouse-handler 'mouse-object-item)
  853.               (walker 'walk-object-item))
  854.         (:constructor make-object-item (object place index ref set)))
  855.   object        ; The Lisp object itself
  856.   string        ; String representation cache
  857.   place            ; Place where it came from
  858.   index            ; Index into where it came from
  859.   ref            ; Function to get object, given place and index
  860.   set            ; Function to set object, given place, index and new value
  861.   )
  862.  
  863. ;;; Object*-Items are like Object-Items except that sometimes they can be like
  864. ;;; string items and be not-selectable.
  865.  
  866. (defstruct (object*-item
  867.         (:print-function print-display-item)
  868.         (:include object-item
  869.               (display 'display-object*-item)
  870.               (tracker 'track-object*-item)
  871.               (untracker 'untrack-object*-item)
  872.               (mouse-handler 'mouse-object*-item))
  873.         (:constructor make-object*-item (string* object live place index ref set)))
  874.   live
  875.   string*)
  876.  
  877. ;;; Inspection item methods (including Scrolling-Inspection-Items).
  878.  
  879. (defun display-inspection-item (self window x0 y0)
  880.   (let ((y (+ y0 border))
  881.     (x (+ x0 border))
  882.     (max-width 0)
  883.     (max-x 0)
  884.     (first-entry-y nil)
  885.     (header-end-y nil)
  886.     (sb (if (scrolling-inspection-item-p self)
  887.         (scrolling-inspection-item-scrollbar self))))
  888.     (when sb
  889.       (funcall (scrollbar-item-reset-index sb) sb))
  890.     ;; First, header items.
  891.     (when (inspection-item-headers self)
  892.       (dolist (item (inspection-item-headers self))
  893.     (multiple-value-bind (width height)
  894.                  (display-item item window x y)
  895.       (incf y height)
  896.       (setq max-width (max max-width width))))
  897.       (setq header-end-y y)
  898.       (incf y vsp))
  899.     (when sb
  900.       (incf x (+ 16 border))
  901.       (funcall (scrollbar-item-reset-index sb) sb))
  902.     ;; Then do entry items.
  903.     (let ((max-name-width 0))
  904.       (setq first-entry-y y)
  905.       ;; Figure out width of widest entry slot name.
  906.       (dolist (item (inspection-item-entries self))
  907.     (when (slot-item-p item)
  908.       (setq max-name-width
  909.         (max max-name-width (length (slot-item-name item))))))
  910.       (dolist (item (inspection-item-entries self))
  911.     (when (slot-item-p item)
  912.       (unless (slot-item-max-name-width item)
  913.         (setf (slot-item-max-name-width item) max-name-width)))
  914.     (multiple-value-bind (width height)
  915.                  (display-item item window x y)
  916.       (incf y height)
  917.       (setq max-width (max max-width (+ width (if sb (+ 16 border) 0)))))))
  918.     (setq max-x (+ x0 border max-width border))
  919.     ;; Display scrollbar, if any.
  920.     (when sb
  921.       (setf (scrollbar-item-bottom sb) y)
  922.       (display-item sb window (+ x0 border) first-entry-y)
  923.       (unless (scrollbar-item-window-width sb)
  924.     (setf (scrollbar-item-window-width sb) (- max-width 16 border))))
  925.     ;; Finally, draw a box around the whole thing.
  926.     (when window
  927.       (draw-box window x0 y0 max-x y)
  928.       (when header-end-y
  929.     (xlib:draw-line window *gcontext* x0 header-end-y max-x header-end-y)))
  930.     ;; And return size.
  931.     (values (- max-x x0) (- (+ y border) y0))))
  932.  
  933. (defun track-inspection-item (self x y)
  934.   (dolist (item (inspection-item-headers self))
  935.     (when (and (<= (display-item-x item) x
  936.            (+ (display-item-x item) (display-item-width item)))
  937.            (<= (display-item-y item) y
  938.            (+ (display-item-y item) (display-item-height item))))
  939.       (track-item item x y)
  940.       (return-from track-inspection-item nil)))
  941.   (track-in-list (inspection-item-entries self) x y))
  942.  
  943. (defun track-scrolling-inspection-item (self x y)
  944.   (dolist (item (inspection-item-headers self))
  945.     (when (and (<= (display-item-x item) x
  946.            (+ (display-item-x item) (display-item-width item)))
  947.            (<= (display-item-y item) y
  948.            (+ (display-item-y item) (display-item-height item))))
  949.       (track-item item x y)
  950.       (return-from track-scrolling-inspection-item nil)))
  951.   (let ((sb (scrolling-inspection-item-scrollbar self)))
  952.     (if (and (<= (display-item-x sb) x (+ (display-item-x sb)
  953.                       (display-item-width sb)))
  954.          (<= (display-item-y sb) y (+ (display-item-y sb)
  955.                       (display-item-height sb))))
  956.     (track-item sb x y)
  957.     (track-in-list (inspection-item-entries self) x y))))
  958.  
  959. (defun walk-inspection-item (self function)
  960.   (let ((*x-constraint* (if (display-item-width self)
  961.                 (+ (display-item-x self)
  962.                    (display-item-width self)
  963.                    (- border))
  964.                 max-window-width)))
  965.     (walk-item-list (inspection-item-headers self) function)
  966.     (walk-item-list (inspection-item-entries self) function)))
  967.  
  968. ;;; Scrollbar item methods.
  969.  
  970. ;;; Yeah, we use a hard-wired constant 16 here, which is the width and height
  971. ;;; of the buttons.  Grody, yeah, but hey, "16" is only two keystrokes...
  972.  
  973. (defun display-scrollbar-item (self window x y)
  974.   (when window
  975.     (draw-bitmap window x y
  976.          (if (eq (scrollbar-item-active-button self) :top)
  977.              *up-arrow-i* *up-arrow*))
  978.     (draw-bitmap window x (- (scrollbar-item-bottom self) 16)
  979.          (if (eq (scrollbar-item-active-button self) :bottom)
  980.              *down-arrow-i* *down-arrow*))
  981.     (draw-box window x (+ y 16) (+ x 15) (- (scrollbar-item-bottom self) 17))
  982.     (setf (scrollbar-item-bar-top self) (+ y 17)
  983.       (scrollbar-item-bar-bottom self) (- (scrollbar-item-bottom self) 17)
  984.       (scrollbar-item-bar-height self) (- (scrollbar-item-bar-bottom self)
  985.                           (scrollbar-item-bar-top self)))
  986.     (draw-block window x
  987.         (+ (scrollbar-item-bar-top self)
  988.            (truncate (* (scrollbar-item-first-index self)
  989.                 (scrollbar-item-bar-height self))
  990.                  (scrollbar-item-num-elements self)))
  991.         (+ x 16)
  992.         (- (scrollbar-item-bar-bottom self)
  993.            (truncate (* (- (scrollbar-item-num-elements self)
  994.                    (+ (scrollbar-item-first-index self)
  995.                       (scrollbar-item-num-elements-displayed self)))
  996.                 (scrollbar-item-bar-height self))
  997.                  (scrollbar-item-num-elements self))))
  998.     (xlib:display-force-output *display*))
  999.   (values 16 (- (scrollbar-item-bottom self) y)))
  1000.  
  1001. (defun track-scrollbar-item (self x y)
  1002.   (update-current-item self x y)
  1003.   (cond ((<= (display-item-y self) y (+ (display-item-y self) 16))
  1004.      (setf (scrollbar-item-active-button self) :top)
  1005.      (draw-bitmap (display-item-window self) 
  1006.               (display-item-x self) (display-item-y self) *up-arrow-i*))
  1007.     ((<= (- (scrollbar-item-bottom self) 16) y (scrollbar-item-bottom self))
  1008.      (setf (scrollbar-item-active-button self) :bottom)
  1009.      (draw-bitmap (display-item-window self) 
  1010.               (display-item-x self) (- (scrollbar-item-bottom self) 16)
  1011.               *down-arrow-i*))
  1012.     (t
  1013.      (untrack-scrollbar-item self)))
  1014.   (xlib:display-force-output *display*))
  1015.  
  1016. (defun untrack-scrollbar-item (self)
  1017.   (cond ((eq (scrollbar-item-active-button self) :top)
  1018.      (draw-bitmap (display-item-window self)
  1019.               (display-item-x self) (display-item-y self) *up-arrow*))
  1020.     ((eq (scrollbar-item-active-button self) :bottom)
  1021.      (draw-bitmap (display-item-window self)
  1022.               (display-item-x self) (- (scrollbar-item-bottom self) 16)
  1023.               *down-arrow*)))
  1024.   (xlib:display-force-output *display*)
  1025.   (setf (scrollbar-item-active-button self) nil))
  1026.  
  1027. ;;; String item methods.
  1028.  
  1029. (defun display-string-item (self window x y)
  1030.   (disp-string window x y (string-item-string self) (string-item-font self)))
  1031.  
  1032. ;;; Slot item methods.
  1033.  
  1034. (defun display-slot-item (self window x y)
  1035.   (let ((name (slot-item-name self))
  1036.     (name-pixel-width (* (+ 2 (slot-item-max-name-width self))
  1037.                  (font-width *entry-font*))))
  1038.     (disp-string window x y name *entry-font*)
  1039.     (multiple-value-bind (width height)
  1040.              (display-item (slot-item-object self)
  1041.                        window (+ x name-pixel-width) y)
  1042.       (values (+ name-pixel-width width border)
  1043.           (max (+ (font-height *entry-font*) vsp) height)))))
  1044.  
  1045. (defun track-slot-item (self x y)
  1046.   (track-item (slot-item-object self) x y))
  1047.  
  1048. (defun walk-slot-item (self function)
  1049.   (walk-item (slot-item-object self) function)
  1050.   (setf (display-item-width self)
  1051.     (+ (* (+ 2 (slot-item-max-name-width self)) (font-width *entry-font*))
  1052.        (display-item-width (slot-item-object self))
  1053.        border)))
  1054.  
  1055. ;;; Scrolling item methods.
  1056.  
  1057. (defun display-scrolling-item (self window x y)
  1058.   (let ((sb (scrolling-item-scrollbar self))
  1059.     (item (scrolling-item-item self)))
  1060.     (funcall (scrollbar-item-next-element sb) item)
  1061.     (let ((*x-constraint* (if (scrollbar-item-window-width sb)
  1062.                   (+ (scrollbar-item-window-width sb) x)
  1063.                   max-window-width)))
  1064.       (multiple-value-bind (width height)
  1065.                (display-item item window x y)
  1066.     (values (or (scrollbar-item-window-width sb) width)
  1067.         height)))))
  1068.  
  1069. (defun track-scrolling-item (self x y)
  1070.   (track-item (scrolling-item-item self) x y))
  1071.  
  1072. (defun walk-scrolling-item (self function)
  1073.   (walk-item (scrolling-item-item self) function))
  1074.  
  1075. ;;; List item methods.
  1076.  
  1077. ;;; If a thing in the item list is a string, we just Disp-String it.
  1078. ;;; That way, we don't have to cons lots of full string items all the time.
  1079.  
  1080. (defun display-list-item (self window x0 y0)
  1081.   (let ((x x0)
  1082.     (max-height 0))
  1083.     (dolist (item (list-item-list self))
  1084.       (multiple-value-bind (width height)
  1085.                (if (stringp item)
  1086.                    (disp-string window x y0 item *entry-font*)
  1087.                    (display-item item window x y0))
  1088.     (incf x width)
  1089.     (setq max-height (max max-height height))))
  1090.     (values (- x x0) max-height)))
  1091.  
  1092. (defun track-list-item (self x y)
  1093.   (track-in-list (list-item-list self) x y))
  1094.  
  1095. (defun walk-list-item (self function)
  1096.   (walk-item-list (list-item-list self) function))
  1097.  
  1098. ;;; Object and Object* item methods.
  1099.  
  1100. (defun display-object-item (self window x y)
  1101.   (unless (object-item-string self)
  1102.     (setf (object-item-string self)
  1103.       (iprin1-to-string (object-item-object self))))
  1104.   (disp-string window x y (object-item-string self) *entry-font*))
  1105.  
  1106. (defun walk-object-item (self function)
  1107.   (funcall function self))
  1108.  
  1109. (defun display-object*-item (self window x y)
  1110.   (if (object*-item-live self)
  1111.       (display-object-item self window x y)
  1112.       (disp-string window x y (object*-item-string* self) *italic-font*)))
  1113.  
  1114. (defun track-object*-item (self x y)
  1115.   (if (or (object*-item-live self) (eq *tracking-mode* :destination))
  1116.       (boxifying-tracker self x y)
  1117.       (update-current-item self x y)))
  1118.  
  1119. (defun untrack-object*-item (self)
  1120.   (when (or (object*-item-live self) (eq *tracking-mode* :destination))
  1121.     (boxifying-untracker self)))
  1122.  
  1123. ;;; Computing display items for Lisp objects.
  1124.  
  1125. ;;; Plan-Display returns a top-level Display-Item for the given Object.
  1126.  
  1127. (defun plan-display (object)
  1128.   (typecase object
  1129.     (pcl::std-instance (plan-display-object object))
  1130.     (structure (plan-display-structure object))
  1131.     (cons (plan-display-list object))
  1132.     (vector (plan-display-vector object))
  1133.     (array (plan-display-array object))
  1134.     (symbol (plan-display-symbol object))
  1135.     (compiled-function (plan-display-function object))
  1136.     (t (plan-display-atomic object))))
  1137.  
  1138. ;;; Replan-Display tries to fix up the existing Plan if possible, but might
  1139. ;;; punt and just return a new Display-Item if things have changed too much.
  1140.  
  1141. (defun replan-display (plan)
  1142.   (let ((object (inspection-item-objects plan)))
  1143.     (typecase object
  1144.       (pcl::std-instance (replan-display-object plan object))
  1145.       (structure (replan-display-structure plan object))
  1146.       (cons (replan-display-list plan object))
  1147.       (vector (replan-display-vector plan object))
  1148.       (array (replan-display-array plan object))
  1149.       (symbol (replan-display-symbol plan object))
  1150.       (compiled-function plan)
  1151.       (t (replan-display-atomic plan object)))))
  1152.  
  1153. ;;; Replan-Object-Item is used at the leaves of the replanning walk.
  1154.  
  1155. (defun replan-object-item (item)
  1156.   (if (object*-item-p item)
  1157.       (multiple-value-bind (decached-object live)
  1158.                (funcall (object-item-ref item)
  1159.                     (object-item-place item) (object-item-index item))
  1160.     (unless (and (eq live (object*-item-live item))
  1161.              (eq decached-object (object-item-object item))
  1162.              (or (symbolp decached-object) (numberp decached-object)
  1163.              ;; ...
  1164.              ))
  1165.       (setf (object*-item-live item) live)
  1166.       (setf (object-item-object item) decached-object)
  1167.       (setf (object-item-string item) nil)
  1168.       (redisplay-item item)))
  1169.       (let ((decached-object (funcall (object-item-ref item)
  1170.                       (object-item-place item) (object-item-index item))))
  1171.     (unless (and (eq decached-object (object-item-object item))
  1172.              (or (symbolp decached-object) (numberp decached-object)
  1173.              ;; ... any others that'll be the same?
  1174.              ))
  1175.       (setf (object-item-object item) decached-object)
  1176.       (setf (object-item-string item) nil)
  1177.       (redisplay-item item)))))
  1178.  
  1179. ;;; For lists, what we stash in the Inspection-Item-Objects slot is the list of
  1180. ;;; the top level conses, rather than the conses themselves.  This lets us detect
  1181. ;;; when conses "in the middle" of the list change.
  1182.  
  1183. (defun plan-display-list (object)
  1184.   (cond #|((and (symbolp (car object))
  1185.           (get (car object) 'lisp::specially-grind))
  1186.        (error "Bliue"))|#
  1187.     ((or (and (< (length (iprin1-to-string object)) inspect-line-length)
  1188.           (<= (length object) inspect-length))
  1189.          (= (length object) 1))
  1190.      (do ((list object (cdr list))
  1191.           (items (list "(")))
  1192.          ((not (consp (cdr list)))
  1193.           (push (make-object-item (car list) list nil 'lref 'lset) items)
  1194.           (when (not (null (cdr list)))
  1195.         (push " . " items)
  1196.         (push (make-object-item (cdr list) list nil 'lref* 'lset*) items))
  1197.           (push ")" items)
  1198.           (make-inspection-item
  1199.            (copy-conses object)
  1200.            nil
  1201.            (list (make-list-item (nreverse items)))))
  1202.        (push (make-object-item (car list) list nil 'lref 'lset) items)
  1203.        (push " " items)))
  1204.     ((<= (length object) inspect-length)
  1205.      (let ((items nil))
  1206.        (push (make-list-item (list "("
  1207.                        (make-object-item
  1208.                     (car object) object nil 'lref 'lset)))
  1209.          items)
  1210.        (do ((list (cdr object) (cdr list)))
  1211.            ((not (consp (cdr list)))
  1212.         (cond ((null (cdr list))
  1213.                (push (make-list-item (list " "
  1214.                            (make-object-item
  1215.                             (car list) list nil 'lref 'lset)
  1216.                            ")"))
  1217.                  items))
  1218.               (t
  1219.                (push (make-list-item (list " "
  1220.                            (make-object-item
  1221.                             (car list) list nil 'lref 'lset)))
  1222.                  items)
  1223.                (push " ." items)
  1224.                (push (make-list-item (list " "
  1225.                            (make-object-item
  1226.                             (cdr list) list nil 'lref* 'lset*)
  1227.                            ")"))
  1228.                  items))))
  1229.          (push (make-list-item (list " "
  1230.                      (make-object-item
  1231.                       (car list) list nil 'lref 'lset)))
  1232.            items))
  1233.        (make-inspection-item (copy-conses object) nil (nreverse items))))
  1234.     (t
  1235.      (let ((scrollbar
  1236.         (let ((index 0)
  1237.               (cons object)
  1238.               (last (last object)))
  1239.           (make-scrollbar-item
  1240.            0
  1241.            (+ (length object) (if (cdr last) 1 0))
  1242.            inspect-length
  1243.            #'(lambda (item)
  1244.                (setf (list-item-list item)
  1245.                  `(,(cond ((eq cons object)
  1246.                        "(")
  1247.                       ((not (consp cons))
  1248.                        " . ")
  1249.                       (t
  1250.                        " "))
  1251.                    ,(if (consp cons)
  1252.                     (make-object-item (car cons) cons nil 'lref 'lset)
  1253.                     (make-object-item cons last nil 'lref* 'lset*))
  1254.                    ,@(if (or (and (eq cons last) (null (cdr cons)))
  1255.                      (atom cons))
  1256.                      `(")"))))
  1257.                (incf index)
  1258.                (unless (atom cons)
  1259.              (setq cons (cdr cons))))
  1260.            #'(lambda (self)
  1261.                (setq index (scrollbar-item-first-index self))
  1262.                (setq cons (nthcdr index object)))))))
  1263.        (setf (scrollbar-item-scrollee scrollbar)
  1264.          (make-scrolling-inspection-item
  1265.           (copy-conses object)
  1266.           nil
  1267.           (let ((items nil))
  1268.             (dotimes (i inspect-length)
  1269.               (push (make-scrolling-item scrollbar (make-list-item nil))
  1270.                 items))
  1271.             (nreverse items))
  1272.           scrollbar)))
  1273.      )))
  1274.  
  1275. ;;; This is kind of like (maplist #'identity list), except that it doesn't
  1276. ;;; choke on non-Nil terminated lists.
  1277.  
  1278. (defun copy-conses (list)
  1279.   (do ((list list (cdr list))
  1280.        (conses nil))
  1281.       ((atom list)
  1282.        (nreverse conses))
  1283.     (push list conses)))
  1284.  
  1285. (defun replan-display-list (plan object)
  1286.   (cond ((do ((list (car object) (cdr list))
  1287.           (conses object (cdr conses)))
  1288.          ((or (null list) (null conses))
  1289.           (and (null list) (null conses)))
  1290.        (unless (and (eq list (car conses))
  1291.             (eq (cdr list) (cadr conses)))
  1292.          (return nil)))
  1293.      (walk-item plan #'replan-object-item)
  1294.      plan)
  1295.     (t
  1296.      (plan-display (car object)))))
  1297.  
  1298. (defun lref (object ignore) (declare (ignore ignore))
  1299.   (car object))
  1300. (defun lref* (object ignore) (declare (ignore ignore))
  1301.   (cdr object))
  1302. (defun lset (object ignore new) (declare (ignore ignore))
  1303.   (setf (car object) new))
  1304. (defun lset* (object ignore new) (declare (ignore ignore))
  1305.   (setf (cdr object) new))
  1306.  
  1307. (defun plan-display-vector (object)
  1308.   (let* ((type (type-of object))
  1309.      (length (array-dimension object 0))
  1310.      (header
  1311.       `(,(make-string-item (format nil "~A" (if (listp type) (car type) type))
  1312.                    *header-font*)
  1313.         ,(make-string-item (format nil "Length = ~D" length)
  1314.                    *header-font*)
  1315.         ,@(if (array-has-fill-pointer-p object)
  1316.           `(,(make-list-item (list "Fill-Pointer: "
  1317.                        (make-object-item
  1318.                         (fill-pointer object)
  1319.                         object nil 'fpref 'fpset))))))))
  1320.      (cond ((<= length inspect-length)
  1321.         (make-inspection-item
  1322.          object
  1323.          header
  1324.          (let ((items nil))
  1325.            (dotimes (i length)
  1326.          (push (make-slot-item (prin1-to-string i)
  1327.                        (make-object-item
  1328.                     (aref object i) object i 'vref 'vset))
  1329.                items))
  1330.            (nreverse items))))
  1331.        (t
  1332.         (let ((scrollbar
  1333.            (let ((index 0))
  1334.              (make-scrollbar-item
  1335.               0
  1336.               length
  1337.               inspect-length
  1338.               #'(lambda (item)
  1339.               (setf (slot-item-name item) (prin1-to-string index))
  1340.               (let ((obj (slot-item-object item)))
  1341.                 (setf (object-item-object obj) (aref object index))
  1342.                 (setf (object-item-index obj) index)
  1343.                 (setf (object-item-string obj) nil))
  1344.               (incf index))
  1345.               #'(lambda (self)
  1346.               (setq index (scrollbar-item-first-index self)))))))
  1347.           (setf (scrollbar-item-scrollee scrollbar)
  1348.             (make-scrolling-inspection-item
  1349.              object
  1350.              header
  1351.              (let ((items nil)
  1352.                (name-width (length (iprin1-to-string (1- length)))))
  1353.                (dotimes (i inspect-length)
  1354.              (let ((slot
  1355.                 (make-slot-item
  1356.                  nil
  1357.                  (make-object-item nil object nil 'vref 'vset))))
  1358.                (setf (slot-item-max-name-width slot) name-width)
  1359.                (push (make-scrolling-item scrollbar slot) items)))
  1360.                (nreverse items))
  1361.              scrollbar)))))))
  1362.  
  1363. (defun replan-display-vector (plan object)
  1364.   (cond ((= (length object) (length (inspection-item-objects plan)))
  1365.      (walk-item plan #'replan-object-item)
  1366.      plan)
  1367.     (t
  1368.      (plan-display object))))
  1369.  
  1370. (defun vref (object index)
  1371.   (if (structurep object)
  1372.       (structure-ref object index)
  1373.       (aref object index)))
  1374. (defun vset (object index new)
  1375.   (if (structurep object)
  1376.       (setf (structure-ref object index) new)
  1377.       (setf (aref object index) new)))
  1378.  
  1379. (defun fpref (object index)
  1380.   (declare (ignore index))
  1381.   (fill-pointer object))
  1382. (defun fpset (object index new)
  1383.   (declare (ignore index))
  1384.   (setf (fill-pointer object) new))
  1385.  
  1386. (defun plan-display-array (object)
  1387.   (lisp::with-array-data ((data object)
  1388.               (start)
  1389.               (end))
  1390.     (let* ((length (- end start))
  1391.        (dimensions (array-dimensions object))
  1392.        (rev-dimensions (reverse dimensions))
  1393.        (header
  1394.         (list (make-string-item
  1395.            (format nil "Array of ~A" (array-element-type object))
  1396.            *header-font*)
  1397.           (make-string-item
  1398.            (format nil "Dimensions = ~S" dimensions)
  1399.            *header-font*))))
  1400.       (cond ((<= length inspect-length)
  1401.          (make-inspection-item
  1402.           object
  1403.           header
  1404.           (let ((items nil))
  1405.         (dotimes (i length)
  1406.           (push (make-slot-item (index-string i rev-dimensions)
  1407.                     (make-object-item
  1408.                      (aref data (+ start i))
  1409.                      object (+ start i) 'vref 'vset))
  1410.             items))
  1411.         (nreverse items))))
  1412.         (t
  1413.          (let ((scrollbar
  1414.             (let ((index 0))
  1415.               (make-scrollbar-item
  1416.                0
  1417.                length
  1418.                inspect-length
  1419.                #'(lambda (item)
  1420.                (setf (slot-item-name item)
  1421.                  (index-string index rev-dimensions))
  1422.                (let ((obj (slot-item-object item)))
  1423.                  (setf (object-item-object obj)
  1424.                    (aref data (+ start index)))
  1425.                  (setf (object-item-index obj) (+ start index))
  1426.                  (setf (object-item-string obj) nil))
  1427.                (incf index))
  1428.                #'(lambda (self)
  1429.                (setq index (scrollbar-item-first-index self)))))))
  1430.            (setf (scrollbar-item-scrollee scrollbar)
  1431.              (make-scrolling-inspection-item
  1432.               object
  1433.               header
  1434.               (let ((items nil)
  1435.                 (name-width (length (index-string (1- length)
  1436.                                   rev-dimensions))))
  1437.             (dotimes (i inspect-length)
  1438.               (let ((slot
  1439.                  (make-slot-item
  1440.                   nil
  1441.                   (make-object-item nil data nil 'vref 'vset))))
  1442.                 (setf (slot-item-max-name-width slot) name-width)
  1443.                 (push (make-scrolling-item scrollbar slot) items)))
  1444.             (nreverse items))
  1445.               scrollbar))))))))
  1446.  
  1447. (defun index-string (index rev-dimensions)
  1448.   (if (null rev-dimensions)
  1449.       "[]"
  1450.       (let ((list nil))
  1451.     (dolist (dim rev-dimensions)
  1452.       (multiple-value-bind (q r)
  1453.                    (floor index dim)
  1454.         (setq index q)
  1455.         (push r list)))
  1456.     (format nil "[~D~{,~D~}]" (car list) (cdr list)))))
  1457.  
  1458. (defun replan-display-array (plan object)
  1459.   (cond ((and (equal (array-dimensions object)
  1460.              (array-dimensions (inspection-item-objects plan)))
  1461.           (lisp::with-array-data ((data1 object)
  1462.                       (start1) (end1))
  1463.         (lisp::with-array-data ((data2 (inspection-item-objects plan))
  1464.                     (start2) (end2))
  1465.           (and (eq data1 data2)
  1466.                (= start1 start2)
  1467.                (= end1 end2)))))
  1468.      (walk-item plan #'replan-object-item)
  1469.      plan)
  1470.     (t
  1471.      (plan-display object))))
  1472.  
  1473. (defun plan-display-atomic (object)
  1474.   (make-inspection-item
  1475.    object
  1476.    nil
  1477.    (list (make-object-item object (list object) nil 'lref 'lset))))
  1478.  
  1479. (defun replan-display-atomic (plan object)
  1480.   (declare (ignore object))
  1481.   (walk-item plan #'replan-object-item)
  1482.   plan)
  1483.  
  1484. (defun plan-display-structure (object)
  1485.  
  1486.   (let* ((dd (info type defined-structure-info (structure-ref object 0)))
  1487.      (dsds (c::dd-slots dd)))
  1488.     (make-inspection-item
  1489.      object
  1490.      (list (make-string-item (format nil "~A ~A"
  1491.                      (symbol-name (c::dd-name dd))
  1492.                      object)
  1493.                  *header-font*))
  1494.      (let ((items nil))
  1495.        (dolist (dsd dsds)
  1496.      (push (make-slot-item (c::dsd-%name dsd)
  1497.                    (make-object-item
  1498.                 (structure-ref object (c::dsd-index dsd))
  1499.                 object (c::dsd-index dsd) 'vref 'vset))
  1500.            items))
  1501.        (nreverse items)))))
  1502.  
  1503. (defun replan-display-structure (plan object)
  1504.   (declare (ignore object))
  1505.   (walk-item plan #'replan-object-item)
  1506.   plan)
  1507.  
  1508. (defun plan-display-object (object)
  1509.   (let ((class (pcl:class-of object)))
  1510.     (make-inspection-item
  1511.      object
  1512.      (list (make-string-item (format nil "~S ~A"
  1513.                      (pcl:class-name class)
  1514.                      object)
  1515.                  *header-font*))
  1516.      (let ((slotds (pcl::slots-to-inspect class object))
  1517.        instance-slots class-slots other-slots)
  1518.        (dolist (slotd slotds)
  1519.      (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
  1520.              slotd
  1521.        (let ((item (make-slot-item (prin1-to-string slot)
  1522.                        (make-object*-item
  1523.                     "Unbound"
  1524.                     (if (pcl:slot-boundp object slot)
  1525.                         (pcl:slot-value object slot))
  1526.                     (pcl:slot-boundp object slot)
  1527.                     object
  1528.                     slot
  1529.                     'ref-slot
  1530.                     'set-slot))))
  1531.          (case allocation
  1532.            (:instance (push item instance-slots))
  1533.            (:class (push item class-slots))
  1534.            (otherwise
  1535.         (setf (slot-item-name item)
  1536.               (format nil "~S [~S]" slot allocation))
  1537.         (push item other-slots))))))
  1538.        (append (unless (null instance-slots)
  1539.          (cons (make-string-item "These slots have :INSTANCE allocation"
  1540.                      *entry-font*)
  1541.                (nreverse instance-slots)))
  1542.            (unless (null class-slots)
  1543.          (cons (make-string-item "These slots have :CLASS allocation"
  1544.                      *entry-font*)
  1545.                (nreverse class-slots)))
  1546.            (unless (null other-slots)
  1547.          (cons (make-string-item "These slots have allocation as shown"
  1548.                      *entry-font*)
  1549.                (nreverse other-slots))))))))
  1550.  
  1551. (defun ref-slot (object slot)
  1552.   (if (pcl:slot-boundp object slot)
  1553.     (values (pcl:slot-value object slot) t)
  1554.     (values nil nil)))
  1555.  
  1556. (defun set-slot (object slot val)
  1557.   (setf (pcl:slot-value object slot) val))
  1558.  
  1559. ;;; Should check to see if we need to redo the entire plan or not.
  1560. (defun replan-display-object (plan object)
  1561.   (declare (ignore plan))
  1562.   (plan-display object))
  1563.  
  1564.  
  1565. (defun plan-display-symbol (object)
  1566.   (make-inspection-item
  1567.    object
  1568.    (list (make-string-item (format nil "Symbol ~A" object) *header-font*))
  1569.    (list (make-slot-item "Value"
  1570.              (make-object*-item
  1571.               "Unbound" (if (boundp object) (symbol-value object))
  1572.               (boundp object) object nil 'valref 'valset))
  1573.      (make-slot-item "Function"
  1574.              (make-object*-item
  1575.               "Undefined" (if (fboundp object) (symbol-function object))
  1576.               (fboundp object) object nil 'defref 'defset))
  1577.      (make-slot-item "Properties"
  1578.              (make-object-item
  1579.               (symbol-plist object) object nil 'plistref 'plistset))
  1580.      (make-slot-item "Package"
  1581.              (make-object-item
  1582.               (symbol-package object) object nil 'packref 'packset)))))
  1583.  
  1584. (defun replan-display-symbol (plan object)
  1585.   (declare (ignore object))
  1586.   (walk-item plan #'replan-object-item)
  1587.   plan)
  1588.  
  1589. (defun valref (object ignore) (declare (ignore ignore))
  1590.   (if (boundp object)
  1591.       (values (symbol-value object) t)
  1592.       (values nil nil)))
  1593. (defun defref (object ignore) (declare (ignore ignore))
  1594.   (if (fboundp object)
  1595.       (values (symbol-function object) t)
  1596.       (values nil nil)))
  1597. (defun plistref (object ignore) (declare (ignore ignore))
  1598.   (symbol-plist object))
  1599. (defun packref (object ignore) (declare (ignore ignore))
  1600.   (symbol-package object))
  1601.  
  1602. (defun valset (object ignore new) (declare (ignore ignore))
  1603.   (setf (symbol-value object) new))
  1604. (defun defset (object ignore new) (declare (ignore ignore))
  1605.   (setf (symbol-function object) new))
  1606. (defun plistset (object ignore new) (declare (ignore ignore))
  1607.   (setf (symbol-plist object) new))
  1608. (defun packset (object ignore new) (declare (ignore ignore))
  1609.   (lisp::%set-symbol-package object new))
  1610.  
  1611. ;;; This is all very gross and silly now, just so we can get something working
  1612. ;;; quickly. Eventually do this with a special stream that listifies things as
  1613. ;;; it goes along...
  1614.  
  1615. (defun plan-display-function (object)
  1616.   (let ((stream (make-string-output-stream)))
  1617.     (let ((*standard-output* stream))
  1618.       (describe object)
  1619.       #+nil
  1620.       (compiler::output-macro-instructions object nil))
  1621.     (close stream)
  1622.     (with-input-from-string (in (get-output-stream-string stream))
  1623.       (plan-display-text
  1624.        object
  1625.        nil
  1626.        #+nil
  1627.        (list
  1628.     (make-string-item (format nil "Function ~S" object) *header-font*)
  1629.     (make-string-item
  1630.      (format nil "Argument list: ~A"
  1631.          (lisp::%sp-header-ref object lisp::%function-arg-names-slot)))
  1632.     (make-string-item
  1633.      (format nil "Defined from:  ~A"
  1634.          (lisp::%sp-header-ref object
  1635.                        lisp::%function-defined-from-slot))))
  1636.        in))))
  1637.  
  1638. (defun plan-display-text (object header stream)
  1639.   (let ((list nil))
  1640.     (do ((line (read-line stream nil nil) (read-line stream nil nil)))
  1641.     ((null line))
  1642.       (push line list))
  1643.     (setq list (nreverse list))
  1644.     (if (<= (length list) inspect-length)
  1645.     (make-inspection-item
  1646.      object
  1647.      header
  1648.      (mapcar #'make-string-item list))
  1649.     (let ((index 0)
  1650.           (vector (coerce list 'vector)))
  1651.       (let ((scrollbar (make-scrollbar-item
  1652.                 0 (length list) inspect-length
  1653.                 #'(lambda (item)
  1654.                 (setf (string-item-string item)
  1655.                       (aref vector index))
  1656.                 (incf index))
  1657.                 #'(lambda (self)
  1658.                 (setq index
  1659.                       (scrollbar-item-first-index self))))))
  1660.         (setf (scrollbar-item-scrollee scrollbar)
  1661.           (make-scrolling-inspection-item
  1662.            object
  1663.            header
  1664.            (let ((items nil))
  1665.              (dotimes (i inspect-length)
  1666.                (push (make-scrolling-item scrollbar
  1667.                           (make-string-item ""))
  1668.                  items))
  1669.              (nreverse items))
  1670.            scrollbar)))))))
  1671.  
  1672. ;;; Displaying old and new plans in old and new windows.
  1673.  
  1674. (defun new-plan-in-new-display (object plan &optional name)
  1675.   (multiple-value-bind (width height) (size-item plan)
  1676.     ;; add border
  1677.     (incf width 10)
  1678.     (incf height 10)
  1679.     (multiple-value-bind (x y) (next-window-position width height)
  1680.       (let* ((window (xlib:create-window :parent *root* :x x :y y
  1681.                      :width width :height height
  1682.                      :background *white-pixel*
  1683.                      :border-width 2))
  1684.          (display-info (make-display-info name object plan window)))
  1685.     (xlib:set-wm-properties window
  1686.                 :name "Inspector Window"
  1687.                 :icon-name "Inspector Display"
  1688.                 :resource-name "Inspector"
  1689.                 :x x :y y :width width :height height
  1690.                 :user-specified-position-p t
  1691.                 :user-specified-size-p t
  1692.                 :min-width width :min-height height
  1693.                 :width-inc nil :height-inc nil)
  1694.     (add-window-display-info-mapping window display-info)
  1695.     (xlib:map-window window)
  1696.     (xlib:clear-area window)
  1697.     (xlib:with-state (window)
  1698.       (setf (xlib:window-event-mask window) important-xevents-mask)
  1699.       (setf (xlib:window-cursor window) *cursor*))
  1700.     (xlib:display-finish-output *display*)
  1701.     (display-item plan window 5 5)
  1702.     (push display-info *display-infos*)
  1703.     (multiple-value-bind
  1704.         (x y same-screen-p child mask root-x root-y root)
  1705.         (xlib:query-pointer window)
  1706.       (declare (ignore same-screen-p child mask root-x root-y root))
  1707.       (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10)))
  1708.         (track-mouse plan x y)))
  1709.     (xlib:display-force-output *display*)
  1710.     display-info))))
  1711.  
  1712. (defun create-display-of-object (object &optional name)
  1713.   (new-plan-in-new-display object (plan-display object) name))
  1714.  
  1715. (defun new-plan-in-old-display (display-info old new)
  1716.   (unless (eq new old)
  1717.     (setf (display-info-display-item display-info) new)
  1718.     (let ((window (display-info-window display-info)))
  1719.       (when (and *current-item*
  1720.          (eql (display-item-window *current-item*) window))
  1721.     (setq *current-item* nil))
  1722.       (multiple-value-bind (width height)
  1723.                (size-item new)
  1724.     (xlib:with-state (window)
  1725.       (setf (xlib:drawable-width window) (+ width 10))
  1726.       (setf (xlib:drawable-height window) (+ height 10)))
  1727.     (xlib:clear-area window)
  1728.     (display-item new window 5 5)
  1729.     (setf (display-item-window new) window
  1730.           (display-item-x new) 5
  1731.           (display-item-y new) 5
  1732.           (display-item-width new) width
  1733.           (display-item-height new) height)
  1734.     (xlib:display-force-output *display*)
  1735.     (multiple-value-bind
  1736.         (x y same-screen-p child mask root-x root-y root)
  1737.         (xlib:query-pointer window)
  1738.       (declare (ignore same-screen-p child mask root-x root-y root))
  1739.       (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10)))
  1740.         (track-mouse new x y)))))))
  1741.  
  1742. (defun update-display-of-object (display-info
  1743.                  &optional
  1744.                  (object (display-info-object display-info)))
  1745.   (cond ((eq object (display-info-object display-info))
  1746.      (new-plan-in-old-display display-info
  1747.                   (display-info-display-item display-info)
  1748.                   (replan-display
  1749.                    (display-info-display-item display-info))))
  1750.     (t
  1751.      (setf (display-info-object display-info) object)
  1752.      (new-plan-in-old-display display-info
  1753.                   (display-info-display-item display-info)
  1754.                   (plan-display object))))
  1755.   (xlib:display-force-output *display*))
  1756.  
  1757.  
  1758. ;;; DELETING-WINDOW-DROP-EVENT checks for any events on win.  If there is one,
  1759. ;;; it is removed from the queue, and t is returned.  Otherwise, returns nil.
  1760. ;;;
  1761. (defun deleting-window-drop-event (display win)
  1762.   (xlib:display-finish-output display)
  1763.   (let ((result nil))
  1764.     (xlib:process-event
  1765.      display :timeout 0
  1766.      :handler #'(lambda (&key event-window window &allow-other-keys)
  1767.           (if (or (eq event-window win) (eq window win))
  1768.               (setf result t)
  1769.               nil)))
  1770.     result))
  1771.  
  1772. (defun remove-display-of-object (display-info)
  1773.   (let ((window (display-info-window display-info)))
  1774.     (setf (xlib:window-event-mask window) #.(xlib:make-event-mask))
  1775.     (xlib:display-finish-output *display*)
  1776.     (loop (unless (deleting-window-drop-event *display* window) (return)))
  1777.     (xlib:destroy-window window)
  1778.     (xlib:display-finish-output *display*)
  1779.     (delete-window-display-info-mapping window)
  1780.     (setq *display-infos* (delete display-info *display-infos*))))
  1781.  
  1782.  
  1783.  
  1784. ;;; The command interpreter.
  1785.  
  1786.  
  1787. (defvar *can-quit* nil)
  1788. (defvar *can-proceed* nil)
  1789. (defvar *unwinding* t)
  1790.  
  1791. (defun try-to-quit ()
  1792.   (setq *current-item* nil)
  1793.   (when *can-quit*
  1794.     (setq *unwinding* nil)
  1795.     (ext:flush-display-events *display*)
  1796.     (throw 'inspect-exit nil))
  1797.   (try-to-proceed))
  1798.  
  1799. (defun try-to-proceed ()
  1800.   (when *can-proceed*
  1801.     (setq *unwinding* nil)
  1802.     (ext:flush-display-events *display*)
  1803.     (throw 'inspect-proceed nil)))
  1804.  
  1805. (defvar *do-command* nil)
  1806.  
  1807. (defun do-command (display-info key-event)
  1808.   (cond (*do-command*
  1809.      (funcall *do-command* display-info key-event))
  1810.     ((or (eq key-event #k"d") (eq key-event #k"D"))
  1811.      ;; Delete current window.
  1812.      (remove-display-of-object display-info)
  1813.      (setq *current-item* nil)
  1814.      (unless *display-infos*
  1815.        (try-to-quit)
  1816.        (try-to-proceed)))
  1817.     ((or (eq key-event #k"h") (eq key-event #k"H") (eq key-event #k"?"))
  1818.      (let ((inspect-length (max inspect-length 30)))
  1819.        (with-open-file (stream help-file-pathname :direction :input)
  1820.          (new-plan-in-new-display
  1821.           nil
  1822.           (plan-display-text nil
  1823.                  (list (make-string-item "Help" *header-font*))
  1824.                  stream)))))
  1825.     ((or (eq key-event #k"m") (eq key-event #k"M"))
  1826.      ;; Modify something.
  1827.      ;; Since the tracking stuff sets up event handlers that can throw past
  1828.      ;; the CLX event dispatching form in INSPECTOR-EVENT-HANDLER, those
  1829.      ;; handlers are responsible for discarding their events when throwing
  1830.      ;; to this CATCH tag.
  1831.      ;;
  1832.      (catch 'quit-modify
  1833.        (let* ((destination-item (track-for-destination))
  1834.           (source (cond
  1835.                ((eq key-event #k"m")
  1836.                 (object-item-object (track-for-source)))
  1837.                (t
  1838.                 (format *query-io*
  1839.                     "~&Form to evaluate for new contents: ")
  1840.                 (force-output *query-io*)
  1841.                 (eval (read *query-io*))))))
  1842.          (funcall (object-item-set destination-item)
  1843.               (object-item-place destination-item)
  1844.               (object-item-index destination-item)
  1845.               source)
  1846.          (update-display-of-object display-info))))
  1847.     ((or (eq key-event #k"q") (eq key-event #k"Q"))
  1848.      ;; Quit.
  1849.      (try-to-quit))
  1850.     ((or (eq key-event #k"p") (eq key-event #k"P"))
  1851.      ;; Proceed.
  1852.      (try-to-proceed))
  1853.     ((or (eq key-event #k"r") (eq key-event #k"R"))
  1854.      ;; Recompute object (decache).
  1855.      (update-display-of-object display-info))
  1856.     ((or (eq key-event #k"u") (eq key-event #k"U"))
  1857.      ;; Up (pop history stack).
  1858.      (when (display-info-stack display-info)
  1859.        (let ((parent (pop (display-info-stack display-info))))
  1860.          (setf (display-info-object display-info) (car parent))
  1861.          (new-plan-in-old-display display-info
  1862.                       (display-info-display-item display-info)
  1863.                       (cdr parent))
  1864.          (update-display-of-object display-info))))
  1865.     ((or (eq key-event #k"Leftdown")
  1866.          (eq key-event #k"Middledown")
  1867.          (eq key-event #k"Rightdown")
  1868.          (eq key-event #k"Super-Leftdown")
  1869.          (eq key-event #k"Super-Middledown")
  1870.          (eq key-event #k"Super-Rightdown"))
  1871.      (when *current-item*
  1872.        (funcall (display-item-mouse-handler *current-item*)
  1873.             *current-item* display-info key-event)))))
  1874.  
  1875.  
  1876. ;;; Stuff to make modification work.
  1877.  
  1878. (defun track-for-destination ()
  1879.   (track-for :destination *cursor-d*))
  1880.  
  1881. (defun track-for-source ()
  1882.   (track-for :source *cursor-s*))
  1883.  
  1884. ;;; TRACK-FOR loops over SYSTEM:SERVE-EVENT waiting for some event handler
  1885. ;;; to throw to this CATCH tag.  Since any such handler throws past
  1886. ;;; SYSTEM:SERVE-EVENT, and therefore, past the CLX event dispatching form
  1887. ;;; in INSPECTOR-EVENT-HANDLER, it is that handler's responsibility to
  1888. ;;; discard its event.
  1889. ;;;
  1890. (defun track-for (tracking-mode cursor)
  1891.   (let ((*tracking-mode* tracking-mode)
  1892.     (*do-command* #'track-for-do-command))
  1893.     (catch 'track-for
  1894.       (unwind-protect
  1895.       (progn
  1896.         (dolist (display-info *display-infos*)
  1897.           (setf (xlib:window-cursor (display-info-window display-info))
  1898.             cursor))
  1899.         (xlib:display-force-output *display*)
  1900.         (loop (system:serve-event)))
  1901.     (dolist (display-info *display-infos*)
  1902.       (setf (xlib:window-cursor (display-info-window display-info))
  1903.         *cursor*))
  1904.     (xlib:display-force-output *display*)))))
  1905.  
  1906. ;;; TRACK-FOR-DO-COMMAND is the "DO-COMMAND" executed when tracking.  Since
  1907. ;;; this throws past the CLX event handling form in INSPECTOR-EVENT-HANDLER,
  1908. ;;; the responsibility for discarding the current event lies here.
  1909. ;;;
  1910. (defun track-for-do-command (display-info key-event)
  1911.   (declare (ignore display-info))
  1912.   (cond
  1913.     ((or (eq key-event #k"q") (eq key-event #k"Q"))
  1914.      (xlib:discard-current-event *display*)
  1915.      (throw 'quit-modify t))
  1916.     ((or (eq key-event #k"Leftdown")
  1917.      (eq key-event #k"Middledown")
  1918.      (eq key-event #k"Rightdown"))
  1919.      (when (object-item-p *current-item*)
  1920.        (throw 'track-for
  1921.           (prog1 *current-item*
  1922.         (when (object*-item-p *current-item*)
  1923.           (untrack-item *current-item*)
  1924.           (setq *current-item* nil))
  1925.         (xlib:discard-current-event *display*)))))))
  1926.  
  1927.  
  1928.  
  1929. ;;; Mouse handler methods (here because they're more like part of the command
  1930. ;;; loop).
  1931.  
  1932. (defvar *inspect-result*)
  1933.  
  1934. (defun nothing-mouse-handler (self display-info key-event)
  1935.   (declare (ignore self display-info key-event))
  1936.   )
  1937.  
  1938. (defun mouse-object-item (self display-info key-event)
  1939.   (cond
  1940.     ((eq key-event #k"Leftdown")
  1941.      ;; Open in current window
  1942.      (push (cons (display-info-object display-info)
  1943.          (display-info-display-item display-info))
  1944.        (display-info-stack display-info))
  1945.      (update-display-of-object display-info (object-item-object self)))
  1946.     ((eq key-event #k"Rightdown")
  1947.      ;; Open in new window
  1948.      (create-display-of-object (object-item-object self)))
  1949.     ((eq key-event #k"Middledown")
  1950.      ;; Return object from inspect
  1951.      (setq *inspect-result* (object-item-object self))
  1952.      (try-to-quit))
  1953.     ((eq key-event #k"Super-Middledown")
  1954.      ;; Return object by leave windows around
  1955.      (setq *inspect-result* (object-item-object self))
  1956.      (try-to-proceed))))
  1957.  
  1958. (defun mouse-object*-item (self display-info key-event)
  1959.   (when (object*-item-live self)
  1960.     (mouse-object-item self display-info key-event)))
  1961.  
  1962. (defun mouse-scrollbar-item (self display-info key-event)
  1963.   (declare (ignore display-info))
  1964.   (let* ((old-first (scrollbar-item-first-index self))
  1965.      (new-first old-first))
  1966.     (cond ((eq (scrollbar-item-active-button self) :bottom)
  1967.        (incf new-first (if (eq key-event #k"Rightdown")
  1968.                    (scrollbar-item-num-elements-displayed self)
  1969.                    1)))
  1970.       ((eq (scrollbar-item-active-button self) :top)
  1971.        (decf new-first (if (eq key-event #k"Rightdown")
  1972.                    (scrollbar-item-num-elements-displayed self)
  1973.                    1)))
  1974.       ((<= (scrollbar-item-bar-top self) *mouse-y*
  1975.            (scrollbar-item-bar-bottom self))
  1976.        (setq new-first (truncate (* (- *mouse-y* (scrollbar-item-bar-top self))
  1977.                     (scrollbar-item-num-elements self))
  1978.                      (scrollbar-item-bar-height self)))))
  1979.     (setq new-first (max new-first 0))
  1980.     (setq new-first (min new-first
  1981.              (- (scrollbar-item-num-elements self)
  1982.                 (scrollbar-item-num-elements-displayed self))))
  1983.     (unless (= new-first old-first)
  1984.       (setf (scrollbar-item-first-index self) new-first)
  1985.       (funcall (scrollbar-item-reset-index self) self)
  1986.       (dolist (item (scrolling-inspection-item-entries
  1987.              (scrollbar-item-scrollee self)))
  1988.     (redisplay-item item))
  1989.       (redisplay-item self))))
  1990.  
  1991. (defun track-mouse (item x y)
  1992.   (track-item item x y))
  1993.  
  1994. ;;; Top-level program interface.
  1995.  
  1996. (defun show-object (object &optional name)
  1997.   (inspect-init)
  1998.   (dolist (display-info *display-infos*)
  1999.     (when (if name
  2000.           (eq name (display-info-name display-info))
  2001.           (eq object (display-info-object display-info)))
  2002.       (update-display-of-object display-info object)
  2003.       (return-from show-object nil)))
  2004.   (create-display-of-object object name))
  2005.  
  2006. (defun remove-object-display (object &optional name)
  2007.   (dolist (display-info *display-infos*)
  2008.     (when (if name
  2009.           (eq name (display-info-name display-info))
  2010.           (eq object (display-info-object display-info)))
  2011.       (remove-display-of-object display-info)
  2012.       (return nil))))
  2013.  
  2014. (defun remove-all-displays ()
  2015.   (dolist (display-info *display-infos*)
  2016.     (remove-display-of-object display-info)))
  2017.  
  2018.  
  2019.  
  2020. ;;; Top-level user interface.
  2021.  
  2022. (defvar *interface-style* :graphics
  2023.   "This specifies the default value for the interface argument to INSPECT.  The
  2024.    default value of this is :graphics, indicating when running under X, INSPECT
  2025.    should use a graphics interface instead of a command-line oriented one.")
  2026.  
  2027. (defun inspect (&optional (object nil object-p)
  2028.               (interface *interface-style*))
  2029.   "This function allows the user to interactively examine Lisp objects.
  2030.    Interface indicates whether this should run with a :graphics interface or a
  2031.    :command-line oriented one; of course, when running without X, there is no
  2032.    choice.  Supplying :window, :windows, :graphics, :graphical, and :x gets a
  2033.    windowing interface, and supplying :command-line or :tty gets the other
  2034.    style.  Invoking this with no arguments resumes inspection of items left
  2035.    active from previous uses, but this only works when running under X."
  2036.   (cond ((or (member interface '(:command-line :tty))
  2037.          (not (assoc :display ext:*environment-list*)))
  2038.      (when object-p (tty-inspect object)))
  2039.     ((not (member interface '(:window :windows :graphics :graphical :x)))
  2040.      (error "Interface must be one of :window, :windows, :graphics, ~
  2041.          :graphical, :x, :command-line, or :tty -- not ~S."
  2042.         interface))
  2043.     (object-p
  2044.      (inspect-init)
  2045.      (let ((disembodied-display-infos nil)
  2046.            (*inspect-result* object)
  2047.            (*x-constraint* max-window-width)
  2048.            (*can-quit* t)
  2049.            (*can-proceed* t))
  2050.        (let ((*display-infos* nil))
  2051.          (create-display-of-object object)
  2052.          (catch 'inspect-proceed
  2053.            (unwind-protect
  2054.            (progn
  2055.              (catch 'inspect-exit
  2056.                (loop (system:serve-event)))
  2057.              (setq *unwinding* t))
  2058.          (when *unwinding*
  2059.            (do ((display-info (pop *display-infos*)
  2060.                       (pop *display-infos*)))
  2061.                ((null display-info))
  2062.              (remove-display-of-object display-info)))))
  2063.          (setq disembodied-display-infos *display-infos*))
  2064.        (dolist (display-info (reverse disembodied-display-infos))
  2065.          (push display-info *display-infos*))
  2066.        *inspect-result*))
  2067.     (*display-infos*
  2068.      (inspect-init)
  2069.      (let ((*inspect-result* nil)
  2070.            (*can-quit* t)
  2071.            (*can-proceed* t))
  2072.        (catch 'inspect-proceed
  2073.          (catch 'inspect-exit
  2074.            (loop (system:serve-event))))
  2075.        *inspect-result*))
  2076.     (t (error "No object supplied for inspection and no previous ~
  2077.            inspection object exists."))))
  2078.