[cmucl/cmucl][master] 2 commits: Remove old sunos stuff from sparc-assem.S

10 Apr 2015

Raymond Toy pushed to master at cmucl / cmucl


Commits:
01777725 by Raymond Toy at 2015-01-17T10:16:39Z
Remove old sunos stuff from sparc-assem.S

We only support Solaris now so remove the old SunOS stuff.  (Besides
we haven't built for SunOS in decades.)

  * globals.h:
    * Solaris uses ELF, so don't prefix names with _.
  * sparc-assem.S:
    * Remove SunOS support.
    * Don't prefix names with _.

- - - - -
419cdec6 by Raymond Toy at 2015-03-07T21:35:05Z
Add clx-inspector contrib module.

Submitted by Fred Gilham, who updated and enhanced the version from
Bill Chiles, Christopher Hoover, and Skef Wholey.

- - - - -


13 changed files:

- + src/contrib/clx-inspector/clx-inspector.asd
- + src/contrib/clx-inspector/clx-inspector.catalog
- + src/contrib/clx-inspector/clx-inspector.lisp
- + src/contrib/clx-inspector/compile-clx-inspector.lisp
- + src/contrib/clx-inspector/inspect11-d.cursor
- + src/contrib/clx-inspector/inspect11-d.mask
- + src/contrib/clx-inspector/inspect11-s.cursor
- + src/contrib/clx-inspector/inspect11-s.mask
- + src/contrib/clx-inspector/inspect11.cursor
- + src/contrib/clx-inspector/inspect11.mask
- + src/contrib/clx-inspector/inspector.help
- src/lisp/globals.h
- src/lisp/sparc-assem.S


Changes:

=====================================
src/contrib/clx-inspector/clx-inspector.asd
=====================================

--- /dev/null
+++ b/src/contrib/clx-inspector/clx-inspector.asd
@@ -0,0 +1,18 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(in-package :asdf)
+
+(require :clx)
+
+(defsystem :clx-inspector
+  :name "INSPECT"
+  :author "Skef Wholey et. al."
+  :maintainer "Fred Gilham"
+  :license "Public Domain"
+  :description "Graphical Inspector"
+  :long-description "Inspector that uses pop-up windows to display the
+  objects. Updates the values of the objects in the background."
+  :components
+  ((:file "clx-inspector")))
+
+

=====================================
src/contrib/clx-inspector/clx-inspector.catalog
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/clx-inspector.catalog
@@ -0,0 +1,39 @@
+Name:
+	CLX Inspector.
+
+Package Name:
+	INSPECT
+
+Description:
+	Adds another inspector style as an alternative to the console
+	inspector. Inspecting objects pops up windows with the
+	contents of the object. The values of the object are updated
+	in the background. Multiple windows can be displayed at the
+	same time.
+	
+
+Author:
+	Original by Skef Wholey. Ported to CLX by Christopher Hoover
+	with "minor tweaks" by Bill Chiles. Updated and enhanced by
+	Fred Gilham.
+
+Net Address:
+        fred@sunbot.homedns.org    
+
+Copyright Status:
+ 	CMUCL public domain code. No Warranty.
+
+Files:
+	clx-inspector.lisp
+	
+
+How to Get:
+        Comes with CMUCL contrib library.
+
+Portability:
+	Depends on CMUCL-specific features.
+
+Instructions:
+	(require :clx-inspector)
+	(inspect <object>) Once the window pops up, you can type "h"
+	to pop up a window of instructions.

=====================================
src/contrib/clx-inspector/clx-inspector.lisp
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/clx-inspector.lisp
@@ -0,0 +1,2214 @@
+;;; -*- Mode: Lisp; Package: INSPECT; Log:code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+#+cmu
+(ext:file-comment
+ "$Header: clx-inspector.lisp,v 1.1 2004/03/12 10:02:30 fmg $")
+;;;
+;;; **********************************************************************
+;;;
+;;; An inspector for CMU Common Lisp.
+;;; 
+;;; Written by Skef Wholey.
+;;; Ported to CLX by Christopher Hoover with minor tweaks by Bill Chiles.
+;;;
+;;; Each Lisp object is displayed in its own X window, and components
+;;; of each object are "mouse sensitive" items that may be selected
+;;; for further investigation.
+;;;
+;;; Some cleanup by FMG plus adding dynamic updating of values when
+;;; multiprocessing is present. (2000-2002)
+;;;
+;;; Converted former "home-made object system" to CLOS.  FMG Oct 2002.
+;;;
+;;; Fix inability to deal with circular lists. Paper over problem with
+;;; PCL and uninitialized slots. FMG March 2004.
+;;;
+;;; Cleanup and minor fixes. FMG 2015. Haha.. ten years.. still works....
+;;; Add scroll wheel support. FMG 2015.
+
+(declaim (optimize (speed 2) (safety 3) (debug 3) (space 1.5) (ext:inhibit-warnings 3)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (provide :clx-inspector))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf lisp::*enable-package-locked-errors* nil))
+
+(in-package "COMMON-LISP-USER")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :clx #+cmu "library:subsystems/clx-library"))
+
+(defpackage "INSPECT"
+  (:use "COMMON-LISP" "LISP" "EXTENSIONS" "KERNEL")
+  (:export inspect show-object remove-object-display remove-all-displays *interface-style*))
+
+(in-package "INSPECT")
+
+
+;;;; Parameters and stuff.
+
+(defvar *inspect-result*)
+
+(defparameter *update-interval* .5
+  "Seconds between item window background updates.")
+
+;;; CLX specials
+
+(defvar *display* nil)
+(defvar *screen* nil)
+(defvar *root* nil)
+(defvar *gcontext* nil)
+(defvar *black-pixel* nil)
+(defvar *white-pixel* nil)
+
+;; Inspect-Length is the number of components that will be displayed in a
+;; window at any one time.  If an object has more than Inspect-Length 
+;; components, we generally put it in a scrolling window.  Inspect-Level
+;; might someday correspond to Print-Level, controlling the amount of
+;; detail and mouse-sensitivity we get inside components, but for now
+;; it's ignored.
+(defparameter inspect-length 30)
+(defparameter inspect-level 1)
+
+;; Inspect-Print-Level and Inspect-Print-Length are used by
+;; IPrin1-To-String to generate the textual representation of
+;; components.
+(defparameter inspect-print-length 10)
+(defparameter inspect-print-level 3)
+
+
+;; The handler-case is an easy way to handle unbound slots. From what
+;; previous versions said, using slot-boundp didn't always work.
+(defun iprin1-to-string (object)
+  (let ((*print-length* inspect-print-length)
+	(*print-level* inspect-print-level)
+	(*print-pretty* nil))
+
+    (handler-case (prin1-to-string object)
+        (unbound-slot () "Unbound"))))
+
+
+;;;; Setting up fonts and cursors and stuff.
+
+;; We use Font structures to keep stuff like the character height and
+;; width of a font around for quick and easy size calculations. For
+;; variable width fonts, the Width slot will be Nil.
+
+(defstruct (font (:constructor make-font (name font height ascent width)))
+  name
+  font
+  height
+  ascent
+  width)
+
+;; The *Header-Font* is a big font usually used for displaying stuff
+;; in the header portion of an object view. *Entry-Font* is used as
+;; the main "body font" for an object, and *Italic-Font* is used for
+;; special stuff.
+
+;; You can go crazy with fonts here.
+;;(defparameter header-font-name "*-*-bold-r-*-sans-14-*-*")
+(defparameter header-font-name "-adobe-helvetica-bold-r-*-*-14-*-*")
+(defvar *header-font*)
+
+;; XXX You must use a fixed-width font here. Variable-width fonts
+;; cause the tracking to fail miserably.
+(defparameter entry-font-name "*-courier-medium-r-normal--12-*-*")
+(defvar *entry-font*)
+
+;; XXX Better to use a fixed-width font here --- a variable-width font
+;; tends to result in bits and pieces of letters getting chopped off.
+(defparameter italic-font-name "*-courier-medium-o-normal--12-*-*")
+(defvar *italic-font*)
+
+;; The *Cursor* is a normal arrow thing used most of the time. During
+;; modification operations, we change the cursor to *Cursor-D* (while
+;; the destination for the modification is being chosen) and
+;; *Cursor-S* (while the source is being chosen).
+
+(defparameter cursor-name "library:contrib/clx-inspector/inspect11.cursor")
+(defvar *cursor*)
+(defparameter cursor-d-name "library:contrib/clx-inspector/inspect11-d.cursor")
+(defvar *cursor-d*)
+(defparameter cursor-s-name "library:contrib/clx-inspector/inspect11-s.cursor")
+(defvar *cursor-s*)
+
+;; This file contains the help message for the inspector. The text in
+;; the file must not extend past the 72nd column, and any initial
+;; whitespace on a line must be built on the space character only. The
+;; window that displays this text is too small in height for easy
+;; reading of this text.
+(defparameter help-file-pathname "library:contrib/clx-inspector/inspector.help")
+
+
+;;;; CLX stuff
+
+;; Max-Window-Width is used to constrain the width of our views.
+
+(declaim (fixnum max-window-width))
+(defparameter max-window-width 1000)
+
+;; Border is the number of pixels between an object view and the box
+;; we draw around it. VSP is the number of pixels we leave between
+;; lines of text. (We should put VSP in the fonts structure sometime
+;; so we can have font-specific vertical spacing.)
+
+(defparameter border 3)
+(defparameter vsp 2)
+
+;; The arrow bitmaps are used inside scrollbars.
+
+(defvar *up-arrow*)
+(defvar *down-arrow*)
+(defvar *up-arrow-i*)
+(defvar *down-arrow-i*)
+
+(defparameter arrow-bits
+  '(#*0000000000000000
+    #*0111111111111110
+    #*0100000000000010
+    #*0100000110000010
+    #*0100001111000010
+    #*0100011111100010
+    #*0100111111110010
+    #*0101111111111010
+    #*0100001111000010
+    #*0100001111000010
+    #*0100001111000010
+    #*0100001111000010
+    #*0100001111000010
+    #*0100000000000010
+    #*0111111111111110
+    #*0000000000000000))
+
+
+;; Font and cursor support
+
+(defun open-font (name)
+  (let* ((font (xlib:open-font *display* name))
+	 (max-width (xlib:max-char-width font))
+	 (min-width (xlib:min-char-width font))
+	 (width (if (= max-width min-width) max-width nil))
+	 (ascent (xlib:max-char-ascent font))
+	 (height (+ (xlib:max-char-descent font) ascent)))
+    (make-font name font height ascent width)))
+
+(defun get-cursor-pixmap-from-file (name)
+  (let ((pathname (probe-file name)))
+    (if pathname
+	(let* ((image (xlib:read-bitmap-file pathname))
+	       (pixmap (xlib:create-pixmap :width 16 :height 16
+					   :depth 1 :drawable *root*))
+	       (gc (xlib:create-gcontext :drawable pixmap
+					 :function boole-1
+					 :foreground *black-pixel*
+					 :background *white-pixel*)))
+	  (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
+	  (xlib:free-gcontext gc)
+	  (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image)))
+	(values nil nil nil))))
+
+(defun open-cursor (name)
+  (multiple-value-bind
+      (cursor-pixmap cursor-x-hot cursor-y-hot)
+      (get-cursor-pixmap-from-file name)
+    (multiple-value-bind
+	(mask-pixmap mask-x-hot mask-y-hot)
+	(get-cursor-pixmap-from-file (make-pathname :type "mask" :defaults name))
+      (declare (ignore mask-x-hot mask-y-hot))
+      (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
+	     (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
+	     (cursor (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
+					 :x cursor-x-hot :y cursor-y-hot
+					 :foreground black :background white)))
+	(xlib:free-pixmap mask-pixmap)
+	(xlib:free-pixmap cursor-pixmap)
+	cursor))))
+
+(defun bitvec-list-to-pixmap (bvl width height)
+  (let* ((image (apply #'xlib:bitmap-image bvl))
+	 (pixmap (xlib:create-pixmap :width width :height height
+				     :drawable *root*
+				     :depth (xlib:screen-root-depth *screen*)))
+	 (gc (xlib:create-gcontext :drawable pixmap
+				   :function boole-1
+				   :foreground *black-pixel*
+				   :background *white-pixel*)))
+    (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16 :bitmap-p t)
+    (xlib:free-gcontext gc)
+    pixmap))
+
+(defun invert-pixmap (pixmap)
+  (let* ((width (xlib:drawable-width pixmap))
+	 (height (xlib:drawable-height pixmap))
+	 (inv-pixmap (xlib:create-pixmap :width width :height height
+					 :drawable *root*
+					 :depth (xlib:screen-root-depth *screen*)))
+	 (gc (xlib:create-gcontext :drawable inv-pixmap
+				   :function boole-c1
+				   :foreground *black-pixel*
+				   :background *white-pixel*)))
+    (xlib:copy-area pixmap gc 0 0 width height inv-pixmap 0 0)
+    (xlib:free-gcontext gc)
+    inv-pixmap))
+
+;;; Draw-Bitmap, Draw-Box, and Draw-Block --- thin wrapper over X
+;;; drawing primitives.
+
+(defun draw-bitmap (window x y pixmap)
+  (xlib:copy-area pixmap *gcontext* 0 0 16 16 window x y))
+
+(defun draw-box (window x1 y1 x2 y2)
+  (declare (fixnum x1 y1 x2 y2))
+  (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1)))
+
+(defun draw-block (window x1 y1 x2 y2)
+  (declare (fixnum x1 y1 x2 y2))
+  (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1) t))
+
+;;; *X-Constraint* is used by Disp-String to truncate long strings so that
+;;; they stay inside windows of reasonable width.
+
+(defvar *x-constraint* nil)
+
+;;; Disp-String draws a string in an X window, trying to constrain it
+;;; to not run beyond the *X-Constraint*.  For variable width fonts,
+;;; we can only guess about the right length...
+
+(defun disp-string (window x y string disp-font)
+  (declare (simple-string string))
+  (let ((font (font-font disp-font))
+	(font-width (font-width disp-font))
+	(font-height (font-height disp-font))
+	(length (length string))
+	(max-width (if *x-constraint* (- *x-constraint* x) max-window-width)))
+    (cond (font-width
+	   ;; fixed width font
+	   (let ((end (if (<= (* length font-width) max-width)
+			  length
+			  (max 0 (truncate max-width font-width)))))
+	     (when window
+	       (xlib:with-gcontext (*gcontext* :font font)
+		 (xlib:draw-image-glyphs window *gcontext*
+					 x (+ y (font-ascent disp-font))
+					 string :end end)))
+	     (values (* end font-width) (+ font-height vsp))))
+	  (t
+	   ;; this is hackish...
+	   (multiple-value-bind (end width)
+	       (do* ((index length (1- index))
+		     (width (xlib:text-width font string :end index)
+			    (xlib:text-width font string :end index)))
+		    ((or (= index 0) (<= width max-width))
+		     (values index width)))
+	     (when window
+	       (xlib:with-gcontext (*gcontext* :font font)
+		 (xlib:draw-image-glyphs window *gcontext*
+					 x (+ y (font-ascent disp-font))
+					 string :end end)))
+	     (values width (+ font-height vsp)))))))
+
+
+
+;;;; Inspect-Init
+
+;;; Inspect-Init sets all this stuff up, using *Inspect-Initialized* to
+;;; know when it's already been done.
+
+(defvar *inspect-initialized* nil)
+
+(defun inspect-init ()
+  (unless *inspect-initialized*
+    
+    (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
+    (ext:carefully-add-font-paths
+     *display*
+     (mapcar #'(lambda (x)
+		 (concatenate 'string (namestring x) "fonts/"))
+ 	     (ext:search-list "library:")))
+    (setq *root* (xlib:screen-root *screen*))
+    (setq *black-pixel* (xlib:screen-black-pixel *screen*))
+    (setq *white-pixel* (xlib:screen-white-pixel *screen*))
+    (setq *gcontext* (xlib:create-gcontext :drawable *root* :function boole-1
+ 					   :foreground *black-pixel*
+ 					   :background *white-pixel*))
+    (setq *cursor* (open-cursor cursor-name))
+    (setq *cursor-d* (open-cursor cursor-d-name))
+    (setq *cursor-s* (open-cursor cursor-s-name))
+    (setq *header-font* (open-font header-font-name))
+    (setq *entry-font* (open-font entry-font-name))
+    (setq *italic-font* (open-font italic-font-name))
+    (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16))
+    (setq *up-arrow-i* (invert-pixmap *up-arrow*))
+    (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16))
+    (setq *down-arrow-i* (invert-pixmap *down-arrow*))
+    (ext:enable-clx-event-handling *display* 'inspector-event-handler)
+    (setq *inspect-initialized* t)))
+
+#|
+;;; For debugging...
+;;; 
+(defun inspect-reinit (&optional (host "unix:0.0"))
+  (let ((win nil))
+    (setq *inspect-initialized* nil)
+    (when *display*
+      (ext:disable-clx-event-handling *display*)
+      (xlib:close-display *display*)))
+    (unwind-protect
+	(progn
+	  (multiple-value-setq
+	      (*display* *screen*)
+	    (ext:open-clx-display host))
+	  (setf (xlib:display-after-function *display*)
+		#'xlib:display-finish-output)
+	  (setq *root* (xlib:screen-root *screen*))
+	  (setq *black-pixel* (xlib:screen-black-pixel *screen*))
+	  (setq *white-pixel* (xlib:screen-white-pixel *screen*))
+	  (setq *gcontext* (xlib:create-gcontext :drawable *root*
+						 :function boole-1
+						 :foreground *black-pixel*
+						 :background *white-pixel*))
+	  (setq *cursor* (open-cursor cursor-name))
+	  (setq *cursor-d* (open-cursor cursor-d-name))
+	  (setq *cursor-s* (open-cursor cursor-s-name))
+	  (setq *header-font* (open-font header-font-name))
+	  (setq *entry-font* (open-font entry-font-name))
+	  (setq *italic-font* (open-font italic-font-name))
+	  (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16))
+	  (setq *up-arrow-i* (invert-pixmap *up-arrow*))
+	  (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16))
+	  (setq *down-arrow-i* (invert-pixmap *down-arrow*))
+	  (setf (xlib:display-after-function *display*) nil)
+	  (setf win t))
+      (cond (win
+	     (ext:enable-clx-event-handling *display* 'inspector-event-handler)
+	     (setq *inspect-initialized* t))
+	    (*display*
+	     (xlib:close-display *display*))))))
+|#
+
+
+;;;; Mid-level interface between inspector and window system.
+
+(defclass view ()
+  ((name :initarg :name :accessor name)
+   (object :initarg :object :accessor object)
+   (view-item :initarg :view-item :accessor view-item)
+   (window :initarg :window :accessor window)
+   #+:mp (update-process :initarg :update-process :accessor update-process :initform nil)
+   (stack :initarg :stack :accessor stack :initform nil))
+  (:documentation "We use view classes to associate objects with their
+graphical images (View-Items, see below), the X windows that they're
+displayed in, and maybe even a user-supplied Name for the whole
+thing."))
+
+#+:mp
+(defun make-view (name object view-item window)
+  (let* ((new-view (make-instance 'view
+				  :name name
+				  :object object
+				  :view-item view-item
+				  :window window)))
+    ;; Create a background process to update the view once per second.
+    (setf (update-process new-view)
+	  (mp:make-process
+	   #'(lambda ()
+	       (loop
+		  (update-view-of-object new-view)
+		  (sleep *update-interval*)))
+	   :name (format nil "Background update process for ~A" name)))
+    new-view))
+
+#-:mp
+(defun make-view (name object view-item window)
+  (make-instance 'view
+		 :name name
+		 :object object
+		 :view-item view-item
+		 :window window))
+
+
+;;; *views* is a list of all the live views of objects.
+;;;
+(defvar *views* nil)
+
+;;; CLX window to view object mapping.
+;;;
+(defvar *windows-to-views* (make-hash-table :test #'eq))
+
+(defun add-window-view-mapping (window view)
+  (setf (gethash window *windows-to-views*) view))
+
+(defun delete-window-view-mapping (window)
+  (remhash window *windows-to-views*))
+
+(defun map-window-to-view (window)
+  (multiple-value-bind (view found-p)
+      (gethash window *windows-to-views*)
+    (unless found-p (error "No such window as ~S in mapping!" window))
+    view))
+
+;; *Tracking-Mode* is a kind of hack used so things know what to do
+;; during modify operations. If it's :Source, only objects that are
+;; really there will be selectable. If it's :Destination, objects that
+;; aren't necessarily really there (like the values of unbound
+;; symbols) will be selectable.
+(declaim (type (member '(:source :destination) *tracking-mode*)))
+(defvar *tracking-mode* :source)
+
+;; *Mouse-X* and *Mouse-Y* are a good approximation of where the mouse
+;; is in the window that the mouse is in.
+
+(declaim (fixnum *mouse-x* *mouse-y*))
+(defvar *mouse-x* 0)
+(defvar *mouse-y* 0)
+
+
+;;;; Event Handling for CLX. Translates events in X windows to
+;;;; commands operating on views.
+
+;; We're interested in these events:
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant important-xevents
+    '(:key-press :button-press :exposure :pointer-motion
+		 :enter-window :leave-window #+notready :structure-notify))
+  
+  (defconstant important-xevents-mask
+    (apply #'xlib:make-event-mask important-xevents)))
+
+
+;; We need to add some mouse key translations to handle the scroll
+;; wheel. XXX These should be in CMUCL, not here.
+
+(ext:define-mouse-keysym 4 25607 "Scrollupdown" "Super" :button-press)
+(ext:define-mouse-keysym 4 25608 "Scrollupup" "Super" :button-release)
+
+(ext:define-mouse-keysym 5 25609 "Scrolldowndown" "Super" :button-press)
+(ext:define-mouse-keysym 5 25610 "Scrolldownup" "Super" :button-release)
+
+
+(defun inspector-event-handler (display)
+  (xlib:event-case (display :discard-p t :force-output-p t :timeout .1)
+    ((:exposure) (event-window count)
+     (when (zerop (the fixnum count))
+       (redisplay-item
+	(view-item (map-window-to-view event-window))))
+     t)
+    ((:key-press) (event-window state code)
+     (do-command (map-window-to-view event-window)
+		 (ext:translate-key-event display code state))
+     t)
+    ((:button-press :button-release) (event-key event-window state code)
+     (do-command (map-window-to-view event-window)
+		 (ext:translate-mouse-key-event code state event-key))
+     t)
+    ((:enter-notify :motion-notify) (event-window x y)
+     (cond ((xlib:event-listen display)
+	    ;; if there are other things in the queue, blow this event off...
+	    nil)
+	   (t
+	    ;; This is the alternative to the background update
+	    ;; process. When the mouse enters the window, its values
+	    ;; get updated.
+	    #-:mp (update-view-of-object (map-window-to-view event-window))
+	    (setf *mouse-x* x)
+	    (setf *mouse-y* y)
+	    (tracker (view-item (map-window-to-view event-window)) x y)
+	    t)))
+    ((:leave-notify) (event-window)
+     (tracker (view-item (map-window-to-view event-window)) -1 -1)
+     t)
+
+    ((:no-exposure) ()
+     ;; just ignore this one
+     t)
+    ((:client-message) (event-window display data)
+     ;; User used the window manager to close a window.
+     (when (eq (xlib:atom-name display (aref data 0)) :wm_delete_window)
+       ;; Make the program think the user hit the "D" key in the event
+       ;; window.
+       (do-command (map-window-to-view event-window) #k"D"))
+     t)
+    (t (event-key)
+       (format t "Inspector received unexpected event, ~S, recieved." event-key)
+       t)))
+
+#|
+
+;;; Some debugging code...
+
+    (xlib:event-cond (display :timeout 0 :peek-p t)
+		     (t (event-key)
+			(unless (eq event-key :motion-notify)
+			  (format t "Event received: ~S~%" event-key))))
+
+(defun discard-event-on-window (display window type)
+  (loop
+    (unless (xlib:process-event display :timeout 0
+	      :handler #'(lambda (&key event-window event-type &allow-other-keys)
+			   (and (eq event-window window)
+				(eq event-type type))))
+      (return))))
+
+|#
+    
+
+;;;; More stuff that interfaces between X and the view stuff.
+
+;; NEXT-WINDOW-POSITION currently uses a very dumb heuristic to decide
+;; where the next inspector window ought to go. If there aren't any
+;; windows, it puts the view of an object in the upper left hand
+;; corner. Otherwise, it'll put it underneath the last one created.
+;; When putting the new window below the last one, if it should extend
+;; below the bottom of the screen, we position it to just fit on the
+;; bottom. Thus, all future windows created in this fashion will "pile
+;; up" on the bottom of the screen.
+;;
+(defun next-window-position (width height)
+  (declare (ignore width))
+  (if *views*
+      (let ((window (window (car *views*))))
+	(xlib:with-state (window)
+	  (let ((drawable-x (xlib:drawable-x window))
+		(drawable-y (xlib:drawable-y window))
+		(drawable-height (xlib:drawable-height window))
+		(border-width (xlib:drawable-border-width window)))
+	    (declare (fixnum drawable-y drawable-height border-width))
+	    (multiple-value-bind (children parent root) (xlib:query-tree window)
+	      (declare (ignore children))
+	      (let ((root-height (xlib:drawable-height root)))
+		(declare (fixnum root-height))
+		(multiple-value-bind
+		    (new-x new-y)
+		    (if (eq parent root)
+			(values drawable-x (+ drawable-y drawable-height
+					      (* 2 border-width)))
+			;; Deal with reparented windows...
+			(multiple-value-bind (root-x root-y)
+					     (xlib:translate-coordinates
+					      parent drawable-x drawable-y root)
+			  (declare (fixnum root-y))
+			  (values root-x (+ root-y drawable-height
+					    (* 2 border-width)))))
+		  (declare (fixnum new-y))
+		  (values new-x
+			  (if (> (+ new-y height border-width) root-height)
+			      (- root-height height border-width)
+			      new-y))))))))
+      (values 200 20)))
+
+
+;;;; View-Item.  A view item is the object that contains the actual
+;;;; underlying object being inspected as well as the window being
+;;;; used to display it and some other information about the window.
+
+(defclass view-item ()
+  ((window :initarg :window :accessor window)
+   (x :initarg :x :accessor x)
+   (y :initarg :y :accessor y)
+   (width :initarg :width :accessor width)
+   (height :initarg :height :accessor height))
+  (:documentation "View-Items are objects with methods to display
+themselves, track the mouse inside their boundries, handle mouse
+clicks on themselves, and so on. Everything we put up on the screen is
+backed in some way by a View-Item. These are the components of the
+total view of an object as described in a view object."))
+
+(defmethod print-object ((item view-item) stream)
+  (format stream "#<~S {~8,'0X}>" (type-of item)
+	  (kernel:get-lisp-obj-address item)))
+	  
+(defgeneric view-item-p (item)
+  (:method ((item t))
+	   nil)
+  (:method ((item view-item))
+	   t))
+
+;; The following generic functions constitute the interface to the
+;; view-item objects. Subclasses of view-item implement behavior by
+;; overriding these methods.
+
+(defgeneric display (item window x y))
+
+(defgeneric tracker (item x y)
+  (:method ((item view-item) x y)
+	   (update-current-item item x y)))
+
+(defgeneric untracker (item)
+  (:method ((item view-item))
+	   nil))
+
+(defgeneric mouse-handler (item view key-event)
+  (:method ((item view-item) view key-event)
+	   (declare (ignore view key-event))
+	   nil))
+
+(defgeneric walker (item function)
+  (:method ((item view-item) function)
+	   (declare (ignore function))
+	   nil))
+
+
+;;;; The following are functions that apply to all view-items.
+
+;; The *Current-Item* is the view item that is currently under the
+;; mouse, to the best of our knowledge, or Nil if the mouse isn't over
+;; an item that does anything with its Tracker method.
+
+(defvar *current-item* nil)
+
+;; Display-Item invokes the Display method of an item to put it up on
+;; the specified window. The window, position, and size are all set,
+;; and the size is returned.
+
+(defun display-item (item window x y)
+  (setf (window item) window
+	(x item) x
+	(y item) y)
+  (multiple-value-bind (width height)
+      (display item window x y)
+    (setf (width item) width)
+    (setf (height item) height)
+    (values width height)))
+
+;; Redisplay-Item redraws an item (if, say, it's changed, or if its
+;; window has received an exposure event). If the item is the
+;; *Current-Item*, we call its tracker method to make sure it gets
+;; highlighted if it's supposed to be.
+
+(defun redisplay-item (item)
+  (when (window item)
+    (xlib:clear-area (window item)
+		     :x (x item) :y (y item)
+		     :width (width item)
+		     :height (height item))
+    (multiple-value-bind (width height)
+	(display item (window item) (x item) (y item))
+      (setf (width item) width)
+      (setf (height item) height))
+    (xlib:display-force-output *display*)
+    (when (and *current-item*
+	       (eq (window *current-item*)
+		   (window item)))
+      (tracker *current-item* *mouse-x* *mouse-y*))))
+
+;; Size-Item uses the Display method to calculate the size of an item
+;; once displayed. If the window supplied to View-Item is Nil, all the
+;; size calculation will get done, but no graphical output will
+;; happen.
+
+(defun size-item (item)
+  (if (slot-boundp item 'width)
+    (values (width item) (height item))
+    (display-item item nil 0 0)))
+
+
+;;;; Tracking and untracking.
+
+;; Update-Current-Item is used by trackers to figure out if an item is
+;; really under the mouse. If it is, and it's not the same as the
+;; *Current-Item*, the *Current-Item* gets untracked. If the mouse is
+;; inside the current item, Update-Current-Item returns T.
+
+(defun update-current-item (item x0 y0)
+  (let ((old-current *current-item*))
+    (with-slots (x y width height) item
+    (if (and (<= x x0 (+ x width))
+	     (<= y y0 (+ y height)))
+      (setq *current-item* item)
+      (setq *current-item* nil))
+    (when (and old-current (not (eq *current-item* old-current)))
+      (untracker old-current)))
+    (eq item *current-item*)))
+
+;; The Boxifying-Tracker and Boxifying-Untracker highlight and
+;; unhighlight an item by drawing or erasing a box around the object.
+
+(defun boxifying-tracker (item x y)
+  (when (update-current-item item x y)
+    (boxify-item item boole-1)))
+
+(defun boxifying-untracker (item)
+  (boxify-item item boole-c1))
+
+(defun boxify-item (item function)
+  (when (view-item-p item)
+    (with-slots (x y width height window) item
+      (xlib:with-gcontext (*gcontext* :function function)
+	(xlib:draw-rectangle window *gcontext* (1- x) y (1+ width) (- height 2)))
+      (xlib:display-force-output *display*))))
+
+;; Track-In-List tries to track inside of each item in the List.
+
+(defun track-in-list (list x0 y0)
+  (dolist (item list)
+    (when (view-item-p item)
+      (with-slots (x y width height) item
+	(when (and (<= x x0 (+ x width))
+		   (<= y y0 (+ y height)))
+	  (tracker item x0 y0)
+	  (return-from track-in-list nil)))))
+  (when *current-item*
+    (untracker *current-item*)
+    (setq *current-item* nil)))
+
+
+;;;; Specialized View-Item definitions.
+
+(defclass inspection-item (view-item)
+  ((objects :initarg :objects :accessor objects)  ; Objects being inspected (for decaching)
+   (headers :initarg :headers :accessor headers)  ; List of items in header, may be Nil
+   (entries :initarg :entries :accessor entries)) ; List of items below header
+  (:documentation "Inspection-Items are used as the `top-level' items
+in the display of an object. They've got a list of header items and a
+list of entry items."))
+
+(defun make-inspection-item (objects headers entries)
+  (make-instance 'inspection-item :objects objects :headers headers :entries entries))
+
+;; Inspection item methods
+
+(defmethod display ((item inspection-item) window x0 y0)
+  (let ((y (+ y0 border))
+	(x (+ x0 border))
+	(max-width 0)
+	(max-x 0)
+	(first-entry-y nil)
+	(header-end-y nil)
+	(sb (when (scrolling-inspection-item-p item)
+	      (scrollbar item))))
+    (when sb
+      (funcall (reset-index sb) sb))
+    ;; First, header items.
+    (when (headers item)
+      (dolist (element (headers item))
+	(multiple-value-bind (width height)
+			     (display-item element window x y)
+	  (incf y height)
+	  (setq max-width (max max-width width))))
+      (setq header-end-y y)
+      (incf y vsp))
+    (when sb
+      (incf x (+ 16 border))
+      (funcall (reset-index sb) sb))
+    ;; Then do entry items.
+    (let ((max-name-width 0))
+      (setq first-entry-y y)
+      ;; Figure out width of widest entry slot name.
+      (dolist (element (entries item))
+	(when (slot-item-p element)
+	  (setq max-name-width
+		(max max-name-width (length (name element))))))
+      (dolist (element (entries item))
+	(when (slot-item-p element)
+	  (unless (slot-boundp element 'max-name-width)
+	    (setf (max-name-width element) max-name-width)))
+	(multiple-value-bind (width height)
+			     (display-item element window x y)
+	  (incf y height)
+	  (setq max-width (max max-width (+ width (if sb (+ 16 border) 0)))))))
+    (setq max-x (+ x0 border max-width border))
+    ;; Display scrollbar, if any.
+    (when sb
+      (setf (bottom sb) y)
+      (display-item sb window (+ x0 border) first-entry-y)
+      (unless (slot-boundp sb 'window-width)
+	(setf (window-width sb) (- max-width 16 border))))
+    ;; Finally, draw a box around the whole thing.
+    (when window
+      (draw-box window x0 y0 max-x y)
+      (when header-end-y
+	(xlib:draw-line window *gcontext* x0 header-end-y max-x header-end-y)))
+    ;; And return size.
+    (values (- max-x x0) (- (+ y border) y0))))
+
+(defmethod tracker ((inspection-item inspection-item) x0 y0)
+  (dolist (item (headers inspection-item))
+    (with-slots (x y width height) item
+      (when (and (<= x x0 (+ x width))
+		 (<= y y0 (+ y height)))
+      (tracker item x0 y0)
+      (return-from tracker nil))))
+  (track-in-list (entries inspection-item) x0 y0))
+
+(defmethod walker ((item inspection-item) function)
+  (flet ((walk-item-list (list function)
+	   (dolist (item list)
+	     (walker item function))))
+    (with-slots (x width) item
+      (let ((*x-constraint* (if (slot-boundp item 'width)
+			      (+ x width (- border))
+			      max-window-width)))
+	(walk-item-list (headers item) function)
+	(walk-item-list (entries item) function)))))
+
+
+(defclass scrolling-inspection-item (inspection-item)
+  ((scrollbar :initarg :scrollbar :accessor scrollbar) ; Scrollbar display item
+   (set-next :initarg :set-next :accessor set-next)    ; To set next state
+   (next :initarg :next :accessor next))               ; To get & increment next state
+  (:documentation "Scrolling-Inspection-Items are used as the
+'top-level' of display of objects that have lots of components and so
+have to scroll. In addition to headers and entries, they've got a
+scrollbar item and stuff so that the entries can lazily compute where
+they are and what they should display."))
+
+(defun make-scrolling-inspection-item (objects headers entries scrollbar)
+  (make-instance 'scrolling-inspection-item 
+		 :objects objects
+		 :headers headers
+		 :entries entries
+		 :scrollbar scrollbar))
+
+(defgeneric scrolling-inspection-item-p (item)
+  (:method ((item t))
+	   nil)
+  (:method ((item scrolling-inspection-item))
+	   t))
+
+;; Scrolling-inspection-item methods.
+
+(defmethod tracker ((item scrolling-inspection-item) x0 y0)
+  (dolist (element (headers item))
+    (with-slots (x y height width) element
+      (when (and (<= x x0 (+ x width))
+		 (<= y y0 (+ y height)))
+	(tracker element x0 y0)
+	(return-from tracker nil))))
+  (let ((sb (scrollbar item)))
+    (with-slots (x y width height) sb
+      (if (and (<= x x0 (+ x width))
+	       (<= y y0 (+ y height)))
+	(tracker sb x0 y0)
+	(track-in-list (entries item) x0 y0)))))
+
+
+
+(defclass scrollbar (view-item)
+  ((scrollee :initarg :scrollee :accessor scrollee) ; Item for which this guy's a scrollbar
+   (bottom :initarg bottom :accessor bottom)        ; Y coordinate of end (hack, hack)
+   (active-button :initarg :active-button :accessor active-button :initform nil)
+   (first-index :initarg :first-index :accessor first-index)    ; Index of first thing to
+					                        ; be displayed
+   (next-element :initarg :next-element :accessor next-element) ; Function to extract next 
+					                        ; element to be displayed
+   (reset-index :initarg :reset-index :accessor reset-index)    ; Function to reset internal
+					                        ; index for next-element
+   (window-width :initarg :window-width :accessor window-width) ; Max X for scrollees
+   (bar-height :initarg :bar-height :accessor bar-height)       ; Height of bar in pixels
+   (bar-top :initarg :bar-top :accessor bar-top)
+   (bar-bottom :initarg :bar-bottom :accessor bar-bottom)
+   (num-elements :initarg :num-elements :accessor num-elements) ; Number of elements in scrollee
+   (num-elements-displayed :initarg :num-elements-displayed
+			   :accessor num-elements-displayed ))  ; Number of elements displayed
+					                        ; at once
+  (:documentation "A Scrollbar has buttons and a thumb bar and the
+stuff it needs to figure out whatever it needs to figure out."))
+
+(defun make-scrollbar (first-index num-elements num-elements-displayed
+			    next-element reset-index)
+  (make-instance 'scrollbar
+		 :first-index first-index :num-elements num-elements
+		 :num-elements-displayed num-elements-displayed
+		 :next-element next-element :reset-index reset-index))
+
+;;; Scrollbar methods.
+
+;; Yeah, we use a hard-wired constant 16 here, which is the width and
+;; height of the buttons. Grody, yeah, but hey, "16" is only two
+;; keystrokes...
+
+(defmethod display ((scrollbar scrollbar) window x y)
+  (with-slots (active-button bottom bar-bottom bar-top bar-height
+	       first-index num-elements num-elements-displayed)
+      scrollbar
+    (when window
+      (draw-bitmap window x y
+		   (if (eq active-button :top)
+		     *up-arrow-i* *up-arrow*))
+      (draw-bitmap window x (- bottom 16)
+		   (if (eq active-button :bottom)
+		     *down-arrow-i* *down-arrow*))
+      (draw-box window x (+ y 16) (+ x 15) (- bottom 17))
+      (setf bar-top (+ y 17)
+	    bar-bottom (- bottom 17)
+	    bar-height (- bar-bottom bar-top))
+      (draw-block window x
+		  (+ bar-top (truncate (* first-index bar-height) num-elements))
+		  (+ x 16)
+		  (- bar-bottom
+		     (truncate (* (- num-elements (+ first-index num-elements-displayed))
+				  bar-height)
+			       num-elements)))
+    (xlib:display-force-output *display*))
+  (values 16 (- bottom y))))
+
+(defmethod tracker ((scrollbar scrollbar) x0 y0)
+  (with-slots (active-button window x y bottom) scrollbar
+    (update-current-item scrollbar x0 y0)
+    (cond ((<= y y0 (+ y 16))
+	   (setf active-button :top)
+	   (draw-bitmap window x y *up-arrow-i*))
+	  ((<= (- bottom 16) y0 bottom)
+	   (setf active-button :bottom)
+	   (draw-bitmap window x (- bottom 16) *down-arrow-i*))
+	  (t
+	   (untracker scrollbar)))
+    (xlib:display-force-output *display*)))
+
+(defmethod untracker ((scrollbar scrollbar))
+  (with-slots (active-button window x y bottom) scrollbar
+    (cond ((eq active-button :top)
+	   (draw-bitmap window x y *up-arrow*))
+	  ((eq active-button :bottom)
+	   (draw-bitmap window x (- bottom 16) *down-arrow*)))
+    (xlib:display-force-output *display*)
+    (setf active-button nil)))
+
+(defmethod mouse-handler ((scrollbar scrollbar) view key-event)
+  (declare (ignore view))
+  (with-slots (first-index active-button num-elements num-elements-displayed
+	       bar-top bar-bottom bar-height scrollee)
+      scrollbar
+    (let* ((old-first first-index)
+	   (new-first old-first))
+      (cond ((or (eq key-event #k"Scrolldowndown") 
+		 (eq active-button :bottom))
+	     (incf new-first
+		   (if (eq key-event #k"Rightdown")
+		       num-elements-displayed
+		       1)))
+	    ((or (eq key-event #k"Scrollupdown")
+		 (eq active-button :top))
+	     (decf new-first
+		   (if (eq key-event #k"Rightdown")
+		       num-elements-displayed
+		       1)))
+	    ((<= bar-top *mouse-y* bar-bottom)
+	     (setq new-first
+		   (truncate (* (- *mouse-y* bar-top)
+				num-elements)
+			     bar-height))))
+      (setq new-first (max new-first 0))
+      (setq new-first (min new-first (- num-elements num-elements-displayed)))
+      (unless (= new-first old-first)
+	(setf first-index new-first)
+	(funcall (reset-index scrollbar) scrollbar)
+	(dolist (element (entries scrollee))
+	  (redisplay-item element))
+	(redisplay-item scrollbar)))))
+
+
+(defclass scrolling-item (view-item)
+  ((scrollbar :initarg :scrollbar :accessor scrollbar)
+   (item :initarg :item :accessor item))
+  (:documentation "Scrolling-Items are used as the entries in
+Scrolling-Inspection-Items. They know the scrollbar that moves them
+around so they can lazily do their stuff."))
+
+(defun make-scrolling-item (scrollbar item)
+  (make-instance 'scrolling-item :scrollbar scrollbar :item item))
+
+;; Scrolling item methods.
+
+(defmethod display ((item scrolling-item) window x y)
+  (with-slots (scrollbar item) item
+    (funcall (next-element scrollbar) item)
+    (let ((*x-constraint* (if (slot-boundp scrollbar 'window-width)
+			    (+ (window-width scrollbar) x)
+			    max-window-width)))
+      (multiple-value-bind (width height) (display item window x y)
+	(values 
+	 (or (and (slot-boundp scrollbar 'window-width)
+		  (window-width scrollbar))
+	     width)
+	 height)))))
+
+(defmethod tracker :before ((scrolling-item scrolling-item) x y)
+  (update-current-item scrolling-item x y))
+
+(defmethod tracker ((scrolling-item scrolling-item) x y)
+  (tracker (item scrolling-item) x y))
+
+(defmethod walker ((scrolling-item scrolling-item) function)
+  (walker (item scrolling-item) function))
+
+
+(defclass string-item (view-item)
+  ((item-string :initarg :item-string :accessor item-string) ; String to be displayed
+   (font :initarg :font :accessor font))      ; Font in which to display it
+  (:documentation "String-Items just have a string of text and a font
+that it gets displayed in."))
+
+(defun make-string-item (string &optional (font *entry-font*))
+  (make-instance 'string-item :item-string string :font font))
+
+;;; String item method.
+
+(defmethod display ((item string-item) window x y)
+  (disp-string window x y (item-string item) (font item)))
+
+
+(defclass slot-item (view-item)
+  ((name :initarg :name :accessor name)              ; String name of slot
+   (object :initarg :object :accessor object)        ; Display item for contents of slot
+   (max-name-width :initarg :max-name-width 
+		   :accessor max-name-width))        ; Length of longest slot name in structure
+  (:documentation "Slot-Items have a string name for the slot (e.g.,
+structure slot name or vector index) and an object item for the
+contents of the slot. The Max-Name-Width is used so that all the slots
+in an inspection item can line their objects up nicely in a
+left-justified column."))
+
+(defun make-slot-item (name object)
+  (make-instance 'slot-item :name name :object object))
+
+(defgeneric slot-item-p (item)
+  (:method ((item t))
+	   nil)
+  (:method ((item slot-item))
+	   t))
+
+;;; Slot item methods.
+
+(defmethod display ((item slot-item) window x y)
+  (with-slots (name object max-name-width) item
+    (let ((name-pixel-width (* (+ 2 max-name-width)
+			       (font-width *entry-font*))))
+      (disp-string window x y name *entry-font*)
+      (multiple-value-bind (width height) (display-item object window (+ x name-pixel-width) y)
+	(values (+ name-pixel-width width border)
+		(max (+ (font-height *entry-font*) vsp) height))))))
+
+(defmethod tracker ((item slot-item) x y)
+  (tracker (object item) x y))
+
+(defmethod walker ((item slot-item) function)
+  (with-slots (object max-name-width) item
+    (walker object function)
+    (setf (width item)
+	  (+ (* (+ 2 max-name-width) (font-width *entry-font*))
+	     (width object)
+	     border))))
+
+
+(defclass list-item (view-item)
+  ((item-list :initarg :item-list :accessor item-list))  ; List of things to be displayed
+  (:documentation "List-Items are used to display several things on
+the same line, one after the other."))
+
+(defun make-list-item (list)
+  (make-instance 'list-item :item-list list))
+
+;;; List item methods.
+
+;; If a thing in the item list is a string, we just Disp-String it.
+;; That way, we don't have to cons lots of full string items all the
+;; time.
+(defmethod display ((item list-item) window x0 y0)
+  (let ((x x0)
+	(max-height 0))
+    (dolist (item (item-list item))
+      (multiple-value-bind (width height)
+	  (if (stringp item)
+	    (disp-string window x y0 item *entry-font*)
+	    (display-item item window x y0))
+	(incf x width)
+	(setq max-height (max max-height height))))
+    (values (- x x0) max-height)))
+
+(defmethod tracker ((item list-item) x y)
+  (track-in-list (item-list item) x y))
+
+(defmethod walker ((item list-item) function)
+  (dolist (element (item-list item))
+    (when (view-item-p element)
+      (walker element function))))
+
+
+(defclass object-item (view-item)
+  ((object :initarg :object :accessor object)  ; The Lisp object itself
+   (item-string :initarg :item-string :accessor item-string) ; String representation cache
+   (place :initarg :place :accessor place)     ; Place where it came from
+   (index :initarg :index :accessor index)     ; Index into where it came from
+   (ref :initarg :ref :accessor ref)           ; Function to get object, given place and index
+   (setter :initarg :setter :accessor setter)) ; Function to set object, given place, index 
+					       ; and new value
+  (:documentation "Object-Items are used to display component Lisp
+objects. They know where the object came from and how to get it again
+(for decaching) and how to change it (for modification)."))
+
+(defun make-object-item (object place index ref set)
+  (make-instance 'object-item :object object :place place :index index :ref ref :setter set))
+
+(defgeneric object-item-p (item)
+  (:method ((item t))
+	   nil)
+  (:method ((item object-item))
+	   t))
+
+;;; Object item methods.
+
+(defmethod display ((item object-item) window x y)
+  (unless (and (slot-boundp item 'item-string) (item-string item))
+    (setf (item-string item) (iprin1-to-string (object item))))
+  (disp-string window x y (item-string item) *entry-font*))
+
+(defmethod tracker ((item object-item) x y)
+  (when (update-current-item item x y)
+    (boxify-item item boole-1)))
+
+(defmethod untracker ((item object-item))
+  (boxify-item item boole-c1))
+
+(defmethod mouse-handler ((item object-item) view key-event)
+  (cond ((eq key-event #k"Leftdown")
+	 ;; Open in current window
+	 (push (cons (object view)
+		     (view-item view))
+	       (stack view))
+	 (update-view-of-object view (object item)))
+
+	((eq key-event #k"Rightdown")
+	 ;; Open in new window
+	 (create-view-of-object (object item) (prin1 (type-of item))))
+
+	((eq key-event #k"Middledown")
+	 ;; Return object from inspect
+	 (setq *inspect-result* (object item))
+	 (try-to-quit))
+
+	((eq key-event #k"Super-Middledown")
+	 ;; Return object but leave windows around
+	 (setq *inspect-result* (object item))
+	 (try-to-proceed))))
+
+(defmethod walker ((item object-item) function)
+  (funcall function item))
+
+;;; Object* items.
+
+(defclass object*-item (object-item)
+   ((live :initarg :live :accessor live)
+    (string* :initarg :string* :accessor string*))
+   (:documentation "Object*-Items are like Object-Items except that
+sometimes they can be like string items and be not-selectable."))
+
+(defun make-object*-item (string* object live place index ref set)
+  (make-instance 'object*-item
+		 :string* string* 
+		 :object object
+		 :live live
+		 :place place
+		 :index index
+		 :ref ref
+		 :setter set))
+
+(defgeneric object*-item-p (item)
+  (:method ((item t))
+	   nil)
+  (:method ((item object*-item))
+	   t))
+
+;;; Object* item methods.
+
+(defmethod display ((item object*-item) window x y)
+  (if (live item)
+    (call-next-method)
+    (disp-string window x y (string* item) *italic-font*)))
+
+(defmethod tracker ((item object*-item) x y)
+  (if (or (live item) (eq *tracking-mode* :destination))
+    (boxifying-tracker item x y)
+    (update-current-item item x y)))
+
+(defmethod untracker ((item object*-item))
+  (when (or (live item) (eq *tracking-mode* :destination))
+    (boxifying-untracker item)))
+
+(defmethod mouse-handler ((item object*-item) view key-event)
+  (when (live item)
+    (call-next-method)))
+
+
+;;;; Display stuff. This uses the methods defined above to actually
+;;;; render the objects onto a visible window.
+
+;; Computing display items for Lisp objects.
+
+
+(defgeneric plan-view (object &key header stream)
+  (:documentation "Plan-View returns a top-level View-Item for the
+  given Object."))
+
+(defgeneric replan-view (object plan)
+  (:documentation "Replan-view tries to fix up the existing Plan if
+possible, but might punt and just return a new View-Item if things
+have changed too much."))
+
+(defun replan (plan)
+  "Replan is for the update function. It sets up the right calling
+  convention for calling the generic replan-view function."
+  (let ((object (objects plan)))
+    (replan-view object plan)))
+
+
+(defun replan-object-item (item)
+  "Replan-Object-Item is used at the leaves of the replanning walk."
+  (if (object*-item-p item)
+      (multiple-value-bind (decached-object live)
+	  (funcall (ref item) (place item) (index item))
+	(unless (and (eq live (live item))
+		     (eq decached-object (object item))
+		     (or (symbolp decached-object) (numberp decached-object)
+			 ;; ...
+			 ))
+	  (setf (live item) live)
+	  (setf (object item) decached-object)
+	  (setf (item-string item) nil)
+	  (redisplay-item item)))
+      (let ((decached-object (funcall (ref item)
+				      (place item) (index item))))
+	(unless (and (eq decached-object (object item))
+		     (or (symbolp decached-object) (numberp decached-object)
+			 ;; ... any others that'll be the same?
+			 ))
+	  (setf (object item) decached-object)
+	  (setf (item-string item) nil)
+	  (redisplay-item item)))))
+
+
+;; Figure out how long random list structures are. Deals with dotted
+;; lists and circular lists.
+
+;;  This routine is too simple --- I'm not sure it always works. In
+;;  particular, I doubt it gives an accurate count for every kind of
+;;  circular list.
+(defun count-conses (list)
+  (if (atom list)
+    (values 0 :atom)
+    (do ((count 1 (1+ count))
+	 (tortoise list)
+	 (tortoise-advance nil (not tortoise-advance))
+	 (hare (cdr list) (cdr hare)))
+	((or (null hare) (not (listp hare)) (eq hare tortoise))
+	 (cond ((null hare)
+		(values count :proper-list))
+	       ((not (listp hare))
+		(values count :dotted-list))
+	       ((eq hare tortoise)
+		(values count :circular-list))))
+      (when tortoise-advance
+	(setf tortoise (cdr tortoise))))))
+     
+
+;; For lists, what we stash in the Inspection-Item-Objects slot is the
+;; list of the top level conses, rather than the conses themselves.
+;; This lets us detect when conses "in the middle" of the list change.
+(defmethod plan-view ((object list) &key &allow-other-keys)
+  (cond 
+    ;; Display the list object as a "list": ( .... )
+    ((or (and (< (size-item (make-string-item (iprin1-to-string object)))
+		 (- max-window-width (* 2 border)))
+	      (<= (count-conses object) inspect-length))
+	 (= (count-conses object) 1))
+     (do ((list object (cdr list))
+	  (i 0 (1+ i))
+	  (items (list "(")))
+	 ((or (not (consp (cdr list)))
+	      ;; The following covers circular lists.
+	      (> i (count-conses object)))
+	  (push (make-object-item (car list) list nil 'lref 'lset) items)
+	  (when (not (null (cdr list)))
+	    (push " . " items)
+	    (push (make-object-item (cdr list) list nil 'lref* 'lset*) items))
+	  (push ")" items)
+	  (make-inspection-item
+	   (copy-n-conses object (count-conses object))
+	   nil
+	   (list (make-list-item (nreverse items)))))
+       (push (make-object-item (car list) list nil 'lref 'lset) items)
+       (push " " items)))
+    
+    ((<= (count-conses object) inspect-length)
+     (let ((items nil))
+       (push (make-list-item (list "("
+				   (make-object-item
+				    (car object) object nil 'lref 'lset)))
+	     items)
+       (do ((list (cdr object) (cdr list)))
+	   ((not (consp (cdr list)))
+	    (cond ((null (cdr list))
+		   (push (make-list-item
+			  (list " "
+				(make-object-item
+				 (car list) list nil 'lref 'lset)
+				")"))
+			 items))
+		  (t
+		   (push (make-list-item
+			  (list " "
+				(make-object-item
+				 (car list) list nil 'lref 'lset)))
+			 items)
+		   (push " ." items)
+		   (push (make-list-item
+			  (list " "
+				(make-object-item
+				 (cdr list) list nil 'lref* 'lset*)
+				")"))
+			 items))))
+	 (push (make-list-item
+		(list " "
+		      (make-object-item
+		       (car list) list nil 'lref 'lset)))
+	       items))
+       (make-inspection-item (copy-n-conses object (count-conses object))
+			     nil (nreverse items))))
+
+    ;; This list is too long --- use a scrolling view.
+    (t
+     (let ((scrollbar
+	    (let ((index 0)
+		  (cons object)
+		  (last (last object)))
+	      (make-scrollbar
+	       0
+	       (+ (count-conses object) (if (cdr last) 1 0))
+	       inspect-length
+	       #'(lambda (item)
+		   (setf (item-list item)
+			 `(,(cond ((eq cons object) "(")
+				  ((not (consp cons)) " . ")
+				  (t " "))
+			   ,(if (consp cons)
+				(make-object-item (car cons) cons nil 'lref 'lset)
+				(make-object-item cons last nil 'lref* 'lset*))
+			   ,@(if (or (and (eq cons last) (null (cdr cons)))
+				     (atom cons))
+				 `(")"))))
+		   (incf index)
+		   (unless (atom cons)
+		     (setq cons (cdr cons))))
+	       #'(lambda (item)
+		   (setq index (first-index item))
+		   (setq cons (nthcdr index object)))))))
+       (setf (scrollee scrollbar)
+	     (make-scrolling-inspection-item
+	      (copy-n-conses object (count-conses object))
+	      nil
+	      (let ((items nil))
+		(dotimes (i inspect-length)
+		  (push (make-scrolling-item scrollbar (make-list-item nil))
+			items))
+		(nreverse items))
+	      scrollbar)))
+	 )))
+
+;; This is kind of like (maplist #'identity list), except that it
+;; doesn't choke on non-nil-terminated lists.
+(defun copy-conses (list)
+  (do ((list list (cdr list))
+       (conses nil))
+      ((atom list)
+       (nreverse conses))
+    (push list conses)))
+
+
+;; This will copy "n" conses; this deals with circular lists.
+(defun copy-n-conses (list n)
+  (do ((i 1 (1+ i))
+       (list list (cdr list))
+       (conses nil))
+      ((or (atom list) (= i n)) (nreverse conses))
+    (push list conses)))
+
+
+(defmethod replan-view ((object list) plan)
+  (cond ((do ((list (car object) (cdr list))
+	      (conses object (cdr conses)))
+	     ((or (null list) (null conses))
+	      (and (null list) (null conses)))
+	   (unless (and (eq list (car conses))
+			(eq (cdr list) (cadr conses)))
+	     (return nil)))
+	 (walker plan #'replan-object-item)
+	 plan)
+	(t
+	 (plan-view (car object)))))
+
+(defun lref (object ignore) (declare (ignore ignore))
+  (car object))
+(defun lref* (object ignore) (declare (ignore ignore))
+  (cdr object))
+(defun lset (object ignore new) (declare (ignore ignore))
+  (setf (car object) new))
+(defun lset* (object ignore new) (declare (ignore ignore))
+  (setf (cdr object) new))
+
+
+(defmethod plan-view ((object vector) &key &allow-other-keys)
+  (let* ((type (type-of object))
+	 (length (array-dimension object 0))
+	 (header
+	  `(,(make-string-item (format nil "~A" (if (listp type) (car type) type))
+			       *header-font*)
+	    ,(make-string-item (format nil "Length = ~D" length)
+			       *header-font*)
+	    ,@(if (array-has-fill-pointer-p object)
+		  `(,(make-list-item (list "Fill-Pointer: "
+					   (make-object-item
+					    (fill-pointer object)
+					    object nil 'fpref 'fpset))))))))
+     (cond ((<= length inspect-length)
+	    (make-inspection-item
+	     object
+	     header
+	     (let ((items nil))
+	       (dotimes (i length)
+		 (push (make-slot-item (prin1-to-string i)
+				       (make-object-item
+					(aref object i) object i 'vref 'vset))
+		       items))
+	       (nreverse items))))
+	   (t
+	    (let ((scrollbar
+		   (let ((index 0))
+		     (make-scrollbar
+		      0
+		      length
+		      inspect-length
+		      #'(lambda (item)
+			  (setf (name item) (prin1-to-string index))
+			  (let ((obj (object item)))
+			    (setf (object obj) (aref object index))
+			    (setf (index obj) index)
+			    (setf (item-string obj) nil))
+			  (incf index))
+		      #'(lambda (item)
+			  (setq index (first-index item)))))))
+	      (setf (scrollee scrollbar)
+		    (make-scrolling-inspection-item
+		     object
+		     header
+		     (let ((items nil)
+			   (name-width (length (iprin1-to-string (1- length)))))
+		       (dotimes (i inspect-length)
+			 (let ((slot
+				(make-slot-item
+				 nil
+				 (make-object-item nil object nil 'vref 'vset))))
+			   (setf (max-name-width slot) name-width)
+			   (push (make-scrolling-item scrollbar slot) items)))
+		       (nreverse items))
+		     scrollbar)))))))
+
+(defmethod replan-view ((object vector) plan)
+  (cond ((= (length object) (length (objects plan)))
+	 (walker plan #'replan-object-item)
+	 plan)
+	(t
+	 (plan-view object))))
+
+(defun vref (object index)
+  (aref object index))
+(defun vset (object index new)
+  (setf (aref object index) new))
+
+(defun fpref (object index)
+  (declare (ignore index))
+  (fill-pointer object))
+(defun fpset (object index new)
+  (declare (ignore index))
+  (setf (fill-pointer object) new))
+
+
+(defmethod plan-view ((object array) &key &allow-other-keys)
+  (lisp::with-array-data ((data object)
+			  (start)
+			  (end))
+    (let* ((length (- end start))
+	   (dimensions (array-dimensions object))
+	   (rev-dimensions (reverse dimensions))
+	   (header
+	    (list (make-string-item
+		   (format nil "Array of ~A" (array-element-type object))
+		   *header-font*)
+		  (make-string-item
+		   (format nil "Dimensions = ~S" dimensions)
+		   *header-font*))))
+      (cond ((<= length inspect-length)
+	     (make-inspection-item
+	      object
+	      header
+	      (let ((items nil))
+		(dotimes (i length)
+		  (push (make-slot-item (index-string i rev-dimensions)
+					(make-object-item
+					 (aref data (+ start i))
+					 object (+ start i) 'vref 'vset))
+			items))
+		(nreverse items))))
+	    (t
+	     (let ((scrollbar
+		    (let ((index 0))
+		      (make-scrollbar
+		       0
+		       length
+		       inspect-length
+		       #'(lambda (item)
+			   (setf (name item)
+				 (index-string index rev-dimensions))
+			   (let ((obj (object item)))
+			     (setf (object obj)
+				   (aref data (+ start index)))
+			     (setf (index obj) (+ start index))
+			     (setf (item-string obj) nil))
+			   (incf index))
+		       #'(lambda (item)
+			   (setq index (first-index item)))))))
+	       (setf (scrollee scrollbar)
+		     (make-scrolling-inspection-item
+		      object
+		      header
+		      (let ((items nil)
+			    (name-width (length (index-string (1- length)
+							      rev-dimensions))))
+			(dotimes (i inspect-length)
+			  (let ((slot
+				 (make-slot-item
+				  nil
+				  (make-object-item nil data nil 'vref 'vset))))
+			    (setf (max-name-width slot) name-width)
+			    (push (make-scrolling-item scrollbar slot) items)))
+			(nreverse items))
+		      scrollbar))))))))
+
+(defun index-string (index rev-dimensions)
+  (if (null rev-dimensions)
+      "[]"
+      (let ((list nil))
+	(dolist (dim rev-dimensions)
+	  (multiple-value-bind (q r)
+			       (floor index dim)
+	    (setq index q)
+	    (push r list)))
+	(format nil "[~D~{,~D~}]" (car list) (cdr list)))))
+
+(defmethod replan-view ((object array) plan)
+  (cond ((and (equal (array-dimensions object)
+		     (array-dimensions (objects plan)))
+	      (lisp::with-array-data ((data1 object)
+				      (start1) (end1))
+		(lisp::with-array-data ((data2 (objects plan))
+					(start2) (end2))
+		  (and (eq data1 data2)
+		       (= start1 start2)
+		       (= end1 end2)))))
+	 (walker plan #'replan-object-item)
+	 plan)
+	(t
+	 (plan-view object))))
+
+
+(defmethod plan-view ((object t) &key &allow-other-keys)
+  (make-inspection-item
+   object
+   nil
+   (list (make-object-item object (list object) nil 'lref 'lset))))
+
+(defmethod replan-view ((object t) plan)
+  (declare (ignore object))
+  (walker plan #'replan-object-item)
+  plan)
+
+
+
+(defmethod plan-view ((object structure-object) &key &allow-other-keys)
+  (let* ((dd (kernel:layout-info (kernel:%instance-layout object)))
+	 (dsds (kernel:dd-slots dd)))
+    (make-inspection-item
+     object
+     (list (make-string-item
+	    (format nil "~A ~A"
+		    (symbol-name (kernel:dd-name dd))
+		    object)
+	    *header-font*))
+     (let ((items nil))
+       (dolist (dsd dsds)
+	 (push (make-slot-item
+		(kernel:dsd-%name dsd)
+		(make-object-item
+		 (funcall (fdefinition (kernel:dsd-accessor dsd)) object)
+		 object (kernel:dsd-index dsd)
+		 #'(lambda (str ignore)
+		     (declare (ignore ignore))
+		     (funcall (fdefinition (kernel:dsd-accessor dsd))
+			      str))
+		 #'(lambda (str ignore val)
+		     (declare (ignore ignore))
+		     (funcall (fdefinition `(setf ,(kernel:dsd-accessor dsd)))
+			      val str))))
+	       items))
+       (nreverse items)))))
+
+(defmethod replan-view ((object structure-object) plan)
+  (declare (ignore object))
+  (walker plan #'replan-object-item)
+  plan)
+
+
+
+(defmethod plan-view ((object standard-object) &key &allow-other-keys)
+  (let ((class (pcl:class-of object)))
+    (make-inspection-item
+     object
+     (list (make-string-item (format nil "~S ~A"
+				     (pcl:class-name class)
+				     object)
+			     *header-font*))
+     (let ((slotds (pcl::slots-to-inspect class object))
+	   instance-slots class-slots other-slots)
+       (dolist (slotd slotds)
+	 (with-slots ((slot pcl::name) (allocation pcl::allocation)) slotd
+	   (let* ((boundp (slot-boundp object slot))
+		  (item (make-slot-item (prin1-to-string slot)
+					(make-object*-item
+					 "Unbound"
+					 (and boundp (slot-value object slot))
+					 boundp
+					 object
+					 slot
+					 'ref-slot
+					 'set-slot))))
+	     (case allocation
+	       (:instance (push item instance-slots))
+	       (:class (push item class-slots))
+	       (otherwise
+		(setf (name item)
+		      (format nil "~S [~S]" slot allocation))
+		(push item other-slots))))))
+       (append (unless (null instance-slots)
+		 (cons (make-string-item "These slots have :INSTANCE allocation"
+					 *entry-font*)
+		       (nreverse instance-slots)))
+	       (unless (null class-slots)
+		 (cons (make-string-item "These slots have :CLASS allocation"
+					 *entry-font*)
+		       (nreverse class-slots)))
+	       (unless (null other-slots)
+		 (cons (make-string-item "These slots have allocation as shown"
+					 *entry-font*)
+		       (nreverse other-slots))))))))
+
+
+(defun ref-slot (object slot)
+  (if (slot-boundp object slot)
+    (values (slot-value object slot) t)
+    (values nil nil)))
+
+(defun set-slot (object slot val)
+  (setf (slot-value object slot) val))
+
+;;; Should check to see if we need to redo the entire plan or not.
+(defmethod replan-view ((object standard-object) plan)
+  (declare (ignore plan))
+  (plan-view object))
+
+
+
+(defmethod plan-view ((object symbol) &key &allow-other-keys)
+  (make-inspection-item
+   object
+   (list (make-string-item (format nil "Symbol ~A" object) *header-font*))
+   (list (make-slot-item "Value"
+			 (make-object*-item
+			  "Unbound" (if (boundp object) (symbol-value object))
+			  (boundp object) object nil 'valref 'valset))
+	 (make-slot-item "Function"
+			 (make-object*-item
+			  "Undefined" (if (fboundp object) (symbol-function object))
+			  (fboundp object) object nil 'defref 'defset))
+	 (make-slot-item "Properties"
+			 (make-object-item
+			  (symbol-plist object) object nil 'plistref 'plistset))
+	 (make-slot-item "Package"
+			 (make-object-item
+			  (symbol-package object) object nil 'packref 'packset)))))
+
+(defmethod replan-view ((object symbol) plan)
+  (declare (ignore object))
+  (walker plan #'replan-object-item)
+  plan)
+
+(defun valref (object ignore) (declare (ignore ignore))
+  (if (boundp object)
+      (values (symbol-value object) t)
+      (values nil nil)))
+(defun defref (object ignore) (declare (ignore ignore))
+  (if (fboundp object)
+      (values (symbol-function object) t)
+      (values nil nil)))
+(defun plistref (object ignore) (declare (ignore ignore))
+  (symbol-plist object))
+(defun packref (object ignore) (declare (ignore ignore))
+  (symbol-package object))
+
+(defun valset (object ignore new) (declare (ignore ignore))
+  (setf (symbol-value object) new))
+(defun defset (object ignore new) (declare (ignore ignore))
+  (setf (symbol-function object) new))
+(defun plistset (object ignore new) (declare (ignore ignore))
+  (setf (symbol-plist object) new))
+(defun packset (object ignore new) (declare (ignore ignore))
+  (lisp::%set-symbol-package object new))
+
+
+;; This is all very gross and silly now, just so we can get something
+;; working quickly. Eventually do this with a special stream that
+;; listifies things as it goes along...
+(defmethod plan-view ((object function) &key &allow-other-keys)
+  (let ((stream (make-string-output-stream)))
+    (let ((*standard-output* stream)
+	  (ext:*describe-print-level* 30))
+      (describe object))
+    (close stream)
+    (with-input-from-string (in (get-output-stream-string stream))
+      (plan-view-text 
+       object
+       (list
+	(make-string-item (format nil "Function ~S" object) *header-font*)
+	(make-string-item
+	 (format nil "Argument list: ~A" (kernel:%function-arglist object))))
+       in))))
+
+
+(defun plan-view-text (object header stream)
+  (let ((list nil))
+    (do ((line (read-line stream nil nil) (read-line stream nil nil)))
+	((null line))
+      (push line list))
+    (setq list (nreverse list))
+    (if (<= (length list) inspect-length)
+	(make-inspection-item
+	 object
+	 header
+	 (mapcar #'make-string-item list))
+	(let ((index 0)
+	      (vector (coerce list 'vector)))
+	  (let ((scrollbar (make-scrollbar
+			    0 (length list) inspect-length
+			    #'(lambda (item)
+				(setf (item-string item)
+				      (aref vector index))
+				(incf index))
+			    #'(lambda (item)
+				(setq index
+				      (first-index item))))))
+	    (setf (scrollee scrollbar)
+		  (make-scrolling-inspection-item
+		   object
+		   header
+		   (let ((items nil))
+		     (dotimes (i inspect-length)
+		       (push 
+			(make-scrolling-item 
+			 scrollbar
+			 ;; This is to ensure that the slots in
+			 ;; the string item are bound.
+			 (let ((string-item (make-string-item "")))
+			   (setf (x string-item) 0
+				 (y string-item) 0
+				 (width string-item) 0
+				 (height string-item) 0)
+			   string-item))
+			items))
+		     (nreverse items))
+		   scrollbar)))))))
+
+
+;;;; Displaying old and new plans in old and new windows.
+
+(defun new-plan-in-new-view (object plan &optional name)
+  (multiple-value-bind (width height) (size-item plan)
+    ;; add border
+    (incf width 10)
+    (incf height 10)
+    (multiple-value-bind (x y) (next-window-position width height)
+      (let* ((window (xlib:create-window :parent *root* :x x :y y
+					 :width width :height height
+					 :background *white-pixel*
+					 :border-width 2))
+	     (view (make-view name object plan window)))
+	(xlib:set-wm-properties window
+				:name "Inspector Window"
+				:icon-name "Inspector Display"
+				:resource-name "Inspector"
+				:x x :y y :width width :height height
+				:user-specified-position-p t
+				:user-specified-size-p t
+				:min-width width :min-height height
+				:width-inc nil :height-inc nil)
+	(setf (xlib:wm-protocols window) `(:wm_delete_window))
+	(add-window-view-mapping window view)
+	(xlib:map-window window)
+	(xlib:clear-area window)
+	(xlib:with-state (window)
+	  (setf (xlib:window-event-mask window) important-xevents-mask)
+	  (setf (xlib:window-cursor window) *cursor*))
+	(xlib:display-finish-output *display*)
+	(display-item plan window 5 5)
+	(push view *views*)
+	(multiple-value-bind
+	    (x y same-screen-p child mask root-x root-y root)
+	    (xlib:query-pointer window)
+	  (declare (ignore same-screen-p child mask root-x root-y root))
+	  (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10)))
+	    (tracker plan x y)))
+	(xlib:display-force-output *display*)
+	view))))
+
+(defun create-view-of-object (object &optional name)
+  (new-plan-in-new-view object (plan-view object) name))
+
+(defun new-plan-in-old-view (view old new)
+  (unless (eq new old)
+    (setf (view-item view) new)
+    (let ((window (window view)))
+      (when (and *current-item*
+		 (eql (window *current-item*) window))
+	(setq *current-item* nil))
+      (multiple-value-bind (width height)
+			   (size-item new)
+	(xlib:with-state (window)
+	  (setf (xlib:drawable-width window) (+ width 10))
+	  (setf (xlib:drawable-height window) (+ height 10)))
+	(xlib:clear-area window)
+	(display-item new window 5 5)
+	(setf (window new) window
+	      (x new) 5
+	      (y new) 5
+	      (width new) width
+	      (height new) height)
+	(xlib:display-force-output *display*)
+	(multiple-value-bind
+	    (x y same-screen-p child mask root-x root-y root)
+	    (xlib:query-pointer window)
+	  (declare (ignore same-screen-p child mask root-x root-y root))
+	  (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10)))
+	    (tracker new x y)))))))
+
+(defun update-view-of-object (view &optional (object (object view)))
+  (cond ((eq object (object view))
+	 (new-plan-in-old-view view
+			       (view-item view)
+			       (replan (view-item view))))
+	(t
+	 (setf (object view) object)
+	 (new-plan-in-old-view view (view-item view) (plan-view object))))
+  (xlib:display-force-output *display*))
+
+
+;; DELETING-WINDOW-DROP-EVENT checks for any events on win. If there
+;; is one, it is removed from the queue, and t is returned. Otherwise,
+;; returns nil.
+(defun deleting-window-drop-event (display win)
+  (xlib:display-finish-output display)
+  (let ((result nil))
+    (xlib:process-event
+     display :timeout 0
+     :handler #'(lambda (&key event-window window &allow-other-keys)
+		  (if (or (eq event-window win) (eq window win))
+		      (setf result t)
+		      nil)))
+    result))
+
+(defun remove-view-of-object (view)
+  (let (#+:mp (update-process (update-process view))
+	(window (window view)))
+    #+:mp (mp:destroy-process update-process)
+    (setf (xlib:window-event-mask window) #.(xlib:make-event-mask))
+    (xlib:display-finish-output *display*)
+    (loop (unless (deleting-window-drop-event *display* window) (return)))
+    (xlib:destroy-window window)
+    (xlib:display-finish-output *display*)
+    (delete-window-view-mapping window)
+    (setq *views* (delete view *views*))))
+
+
+;;;; The command interpreter.
+
+(defvar *can-quit* nil)
+(defvar *can-proceed* nil)
+(defvar *unwinding* t)
+
+(defun try-to-quit ()
+  (setq *current-item* nil)
+  (when *can-quit*
+    (setq *unwinding* nil)
+    (ext:flush-display-events *display*)
+    (throw 'inspect-exit nil))
+  (try-to-proceed))
+
+(defun try-to-proceed ()
+  (when *can-proceed*
+    (setq *unwinding* nil)
+    (ext:flush-display-events *display*)
+    (throw 'inspect-proceed nil)))
+
+(defvar *do-command* nil)
+
+(defun do-command (view key-event)
+  (cond (*do-command*
+	 (funcall *do-command* view key-event))
+
+	;; If we get scrollwheel down key events anywhere in the view,
+	;; the scrollbar wants to know about them. Yes, a bit
+	;; ad-hoc....
+	((and (or (eq key-event #k"Scrollupdown") 
+		  (eq key-event #k"Scrolldowndown"))
+	      (typep (view-item view) 'scrolling-inspection-item))
+	 (dotimes (i 5) ; Simulate multiple clicks.
+	   (mouse-handler (scrollbar (view-item view)) view key-event)))
+
+	((or (eq key-event #k"d") (eq key-event #k"D"))
+	 ;; Delete current window.
+	 (remove-view-of-object view)
+	 (setq *current-item* nil)
+	 (unless *views*
+	   (try-to-quit)
+	   (try-to-proceed)))
+
+	((or (eq key-event #k"h") (eq key-event #k"H") (eq key-event #k"?"))
+	 (let ((inspect-length (max inspect-length 30)))
+	   (with-open-file (stream help-file-pathname :direction :input)
+	     (new-plan-in-new-view
+	      nil
+	      (plan-view-text nil
+			      (list (make-string-item "Help" *header-font*))
+			      stream)
+	      "Help Window"))))
+
+	((or (eq key-event #k"m") (eq key-event #k"M"))
+	 ;; Modify something.
+	 ;; Since the tracking stuff sets up event handlers that can
+	 ;; throw past the CLX event dispatching form in
+	 ;; INSPECTOR-EVENT-HANDLER, those handlers are responsible
+	 ;; for discarding their events when throwing to this CATCH
+	 ;; tag.
+	 (catch 'quit-modify
+	   (let* ((destination-item (track-for-destination))
+		  (source (cond
+			   ((eq key-event #k"m")
+			    (object (track-for-source)))
+			   (t
+			    (format *query-io*
+				    "~&Form to evaluate for new contents: ")
+			    (force-output *query-io*)
+			    (eval (read *query-io*))))))
+	     (funcall (setter destination-item)
+		      (place destination-item)
+		      (index destination-item)
+		      source)
+	     (update-view-of-object view))))
+
+	((or (eq key-event #k"q") (eq key-event #k"Q"))
+	 ;; Quit.
+	 (try-to-quit))
+
+	((or (eq key-event #k"p") (eq key-event #k"P"))
+	 ;; Proceed.
+	 (try-to-proceed))
+
+	((or (eq key-event #k"r") (eq key-event #k"R"))
+	 ;; Recompute object (decache).
+	 (update-view-of-object view))
+
+	((or (eq key-event #k"u") (eq key-event #k"U"))
+	 ;; Up (pop history stack).
+	 (when (stack view)
+	   (let ((parent (pop (stack view))))
+	     (setf (object view) (car parent))
+	     (new-plan-in-old-view view (view-item view) (cdr parent))
+	     (update-view-of-object view))))
+
+	((or (eq key-event #k"Leftdown")
+	     (eq key-event #k"Middledown")
+	     (eq key-event #k"Rightdown")
+	     (eq key-event #k"Super-Leftdown")
+	     (eq key-event #k"Super-Middledown")
+	     (eq key-event #k"Super-Rightdown")
+;;	     (eq key-event #k"Scrollupdown")
+;;	     (eq key-event #k"Scrolldowndown")
+;;	     (eq key-event #k"Super-Scrollupdown")
+;;	     (eq key-event #k"Super-Scrolldowndown")
+	     )
+
+	 (when *current-item*
+	   (mouse-handler *current-item* view key-event)))))
+
+
+;;;; Stuff to make modification work.
+
+(defun track-for-destination ()
+  (track-for :destination *cursor-d*))
+
+(defun track-for-source ()
+  (track-for :source *cursor-s*))
+
+;; TRACK-FOR loops over SYSTEM:SERVE-EVENT waiting for some event
+;; handler to throw to this CATCH tag. Since any such handler throws
+;; past SYSTEM:SERVE-EVENT, and therefore, past the CLX event
+;; dispatching form in INSPECTOR-EVENT-HANDLER, it is that handler's
+;; responsibility to discard its event.
+(defun track-for (tracking-mode cursor)
+  (let ((*tracking-mode* tracking-mode)
+	(*do-command* #'track-for-do-command))
+    (catch 'track-for
+      (unwind-protect
+	  (progn
+	    (dolist (view *views*)
+	      (setf (xlib:window-cursor (window view))
+		    cursor))
+	    (xlib:display-force-output *display*)
+	    (loop
+	     (system:serve-event)))
+	(dolist (view *views*)
+	  (setf (xlib:window-cursor (window view))
+		*cursor*))
+	(xlib:display-force-output *display*)))))
+
+;; TRACK-FOR-DO-COMMAND is the "DO-COMMAND" executed when tracking.
+;; Since this throws past the CLX event handling form in
+;; INSPECTOR-EVENT-HANDLER, the responsibility for discarding the
+;; current event lies here.
+(defun track-for-do-command (view key-event)
+  (declare (ignore view))
+  (cond
+    ((or (eq key-event #k"q") (eq key-event #k"Q"))
+     (xlib:discard-current-event *display*)
+     (throw 'quit-modify t))
+    ((or (eq key-event #k"Leftdown")
+	 (eq key-event #k"Middledown")
+	 (eq key-event #k"Rightdown"))
+     (when (object-item-p *current-item*)
+       (throw 'track-for
+	      (prog1 *current-item*
+		(when (object*-item-p *current-item*)
+		  (untracker *current-item*)
+		  (setq *current-item* nil))
+		(xlib:discard-current-event *display*)))))))
+
+
+
+;;;; Top-level program interface.
+
+(defun show-object (object &optional name)
+  (inspect-init)
+  (dolist (view *views*)
+    (when (if name
+	      (eq name (name view))
+	      (eq object (object view)))
+      (update-view-of-object view object)
+      (return-from show-object nil)))
+  (create-view-of-object object name))
+
+(defun remove-object-view (object &optional name)
+  (dolist (view *views*)
+    (when (if name
+	      (eq name (name view))
+	      (eq object (object view)))
+      (remove-view-of-object view)
+      (return nil))))
+
+(defun remove-all-views ()
+  (dolist (view *views*)
+    (remove-view-of-object view)))
+
+
+
+;;;; Top-level user interface.
+
+(defvar *interface-style* :graphics
+  "This specifies the default value for the interface argument to INSPECT.  The
+   default value of this is :graphics, indicating when running under X, INSPECT
+   should use a graphics interface instead of a command-line oriented one.")
+
+(defun inspect (&optional (object nil object-p)
+			  (interface *interface-style*))
+  "(inspect <object> <interface>)
+
+Interactively examine Lisp objects.
+
+Arguments:
+
+object: The object to examine.
+
+interface: one of [:window :windows :graphics :graphical :x 
+                   :command-line :tty]
+
+Any of [:window :windows :graphics :graphical :x] give a windowing
+interface. Once you've got a window, type <h> or <H> to get a help
+window explaining how to use it.
+
+Either of [:command-line :tty] gives a pure command-line inspector.
+
+If <interface> is not supplied, the default is to use a windowing
+interface if running under X11, and a command-line interface if not.
+
+If neither argument is given, the windowing version of inspect will
+resume inspection of items left active from previous uses if there are
+any, otherwise give an error. The command-line interface will give an
+error."
+  (cond ((or (member interface '(:command-line :tty))
+	     (not (assoc :display ext:*environment-list*)))
+	 (when object-p (tty-inspect object)))
+	((not (member interface '(:window :windows :graphics :graphical :x)))
+	 (error "Interface must be one of :window, :windows, :graphics, ~
+		 :graphical, :x, :command-line, or :tty -- not ~S."
+		interface))
+	(object-p
+	 (inspect-init)
+	 (let ((disembodied-views nil)
+	       (*inspect-result* object)
+	       (*x-constraint* max-window-width)
+	       (*can-quit* t)
+	       (*can-proceed* t))
+	   (let ((*views* nil))
+	     (create-view-of-object object "User Supplied Object")
+	     (catch 'inspect-proceed
+	       (unwind-protect
+		   (progn
+		     (catch 'inspect-exit
+		       (loop
+			(system:serve-event)))
+		     (setq *unwinding* t))
+		 (when *unwinding*
+		   (do ((view (pop *views*)
+			      (pop *views*)))
+		       ((null view))
+		     (remove-view-of-object view)))))
+	     (setq disembodied-views *views*))
+	   (dolist (view (reverse disembodied-views))
+	     (push view *views*))
+	   *inspect-result*))
+	(*views*
+	 (inspect-init)
+	 (let ((*inspect-result* nil)
+	       (*can-quit* t)
+	       (*can-proceed* t))
+	   (catch 'inspect-proceed
+	     (catch 'inspect-exit
+	       (loop
+		(system:serve-event))))
+	   *inspect-result*))
+	(t (error "No object supplied for inspection and no previous ~
+		   inspection object exists."))))

=====================================
src/contrib/clx-inspector/compile-clx-inspector.lisp
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/compile-clx-inspector.lisp
@@ -0,0 +1,2 @@
+(compile-file "modules:clx-inspector/clx-inspector"
+	      :load t)

=====================================
src/contrib/clx-inspector/inspect11-d.cursor
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspect11-d.cursor
@@ -0,0 +1,8 @@
+#define inspect-d_width 16
+#define inspect-d_height 16
+#define inspect-d_x_hot 1
+#define inspect-d_y_hot 1
+static char inspect-d_bits[] = {
+ 0x00,0x00,0x02,0x00,0x06,0x00,0x0e,0x00,0x1e,0x00,0x3e,0x00,0x7e,0x00,0xfe,
+ 0x00,0xfe,0x45,0x3e,0x6c,0x36,0x54,0x62,0x54,0x60,0x44,0xc0,0x44,0xc0,0x44,
+ 0x00,0x00};

=====================================
src/contrib/clx-inspector/inspect11-d.mask
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspect11-d.mask
@@ -0,0 +1,6 @@
+#define inspect-d_width 16
+#define inspect-d_height 16
+static char inspect-d_bits[] = {
+ 0x07,0x00,0x0f,0x00,0x1f,0x00,0x3f,0x00,0x7f,0x00,0xff,0x00,0xff,0x01,0xff,
+ 0xef,0xff,0xff,0x7f,0xfe,0xff,0xfe,0xff,0xfe,0xf7,0xef,0xe0,0xef,0xe0,0xef,
+ 0xe0,0xef};

=====================================
src/contrib/clx-inspector/inspect11-s.cursor
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspect11-s.cursor
@@ -0,0 +1,8 @@
+#define inspect-s_width 16
+#define inspect-s_height 16
+#define inspect-s_x_hot 1
+#define inspect-s_y_hot 1
+static char inspect-s_bits[] = {
+ 0x00,0x00,0x02,0x00,0x06,0x00,0x0e,0x00,0x1e,0x00,0x3e,0x00,0x7e,0x00,0xfe,
+ 0x00,0xfe,0x79,0x3e,0x44,0x36,0x04,0x62,0x38,0x60,0x40,0xc0,0x44,0xc0,0x3c,
+ 0x00,0x00};

=====================================
src/contrib/clx-inspector/inspect11-s.mask
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspect11-s.mask
@@ -0,0 +1,6 @@
+#define inspect-s_width 16
+#define inspect-s_height 16
+static char inspect-s_bits[] = {
+ 0x07,0x00,0x0f,0x00,0x1f,0x00,0x3f,0x00,0x7f,0x00,0xff,0x00,0xff,0x01,0xff,
+ 0xfd,0xff,0xff,0x7f,0xfe,0xff,0x7e,0xff,0xfc,0xf7,0xff,0xe0,0xff,0xe0,0x7f,
+ 0xe0,0x7f};

=====================================
src/contrib/clx-inspector/inspect11.cursor
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspect11.cursor
@@ -0,0 +1,8 @@
+#define inspect_width 16
+#define inspect_height 16
+#define inspect_x_hot 3
+#define inspect_y_hot 1
+static char inspect_bits[] = {
+ 0x00,0x00,0x08,0x00,0x18,0x00,0x38,0x00,0x78,0x00,0xf8,0x00,0xf8,0x01,0xf8,
+ 0x03,0xf8,0x07,0xf8,0x00,0xd8,0x00,0x88,0x01,0x80,0x01,0x00,0x03,0x00,0x03,
+ 0x00,0x00};

=====================================
src/contrib/clx-inspector/inspect11.mask
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspect11.mask
@@ -0,0 +1,6 @@
+#define inspect_width 16
+#define inspect_height 16
+static char inspect_bits[] = {
+ 0x0c,0x00,0x1c,0x00,0x3c,0x00,0x7c,0x00,0xfc,0x00,0xfc,0x01,0xfc,0x03,0xfc,
+ 0x07,0xfc,0x0f,0xfc,0x0f,0xfc,0x01,0xdc,0x03,0xcc,0x03,0x80,0x07,0x80,0x07,
+ 0x00,0x03};

=====================================
src/contrib/clx-inspector/inspector.help
=====================================
--- /dev/null
+++ b/src/contrib/clx-inspector/inspector.help
@@ -0,0 +1,73 @@
+The component objects of the window's object will become highlighted    
+(surrounded by a box) as the mouse passes over them.  In an inspector
+window, keystrokes and mouse clicks are interpreted as follows:
+
+        Left            When the mouse is over a component object,
+                        clicking Left will inspect that object in
+                        the current inspector window.  The "up" command
+                        (below) can be used to return to the current
+                        object.
+
+        Middle          When the mouse is over a component object,
+                        clicking Middle will exit the inspector, deleting
+                        all new windows, and returning the component
+                        as the result of the call to Inspect.
+
+        Right           When the mouse is over a component object,
+                        clicking Right will inspect that object in
+                        a new inspector window.
+
+        Shift-Middle    When the mouse is over a component object,
+                        clicking Shift-Middle will exit the inspector,
+                        leaving all windows displayed, and returning the
+                        component as the result of the call to Inspect.
+
+        d, D            Typing "d" or "D" inside an inspector window
+                        will delete that window, and exit the inspector
+                        if there are no more inspector windows.
+
+        h, H, ?         Typing "h", "H", or "?" inside an inspector
+                        window will create a window with helpful
+                        instructions.
+
+        m, M            Typing "m" or "M" inside an inspector window
+                        will allow one to modify a component of an
+                        object.  The mouse cursor will change from an
+                        arrow to an arrow with an "M" beside it,
+                        indicating that one should select the component
+                        to be modified.  Clicking any mouse button while
+                        the mouse is over a component will select that
+                        component as a destination for modification.
+
+                        If one has typed "m", the source object will
+                        also be selected by the mouse, with the mouse
+                        cursor changed to an arrow with an "S" beside
+                        it.  The object will replace the destination
+                        component.
+
+                        If one has typed "M", the source object will be
+                        prompted for on the *Query-IO* stream.
+
+                        When choosing the destination or source with the
+                        mouse, one may type "q" or "Q" to abort the
+                        modify operation.
+
+        q, Q            Typing "q" or "Q" will quit the inspector,
+                        deleting all new inspector windows.
+
+        p, P            Typing "p" or "P" will proceed from the
+                        inspector, leaving all inspector windows intact.
+
+        r, R            Typing "r" or "R" will recompute the display for
+                        the object in the window.  This is used to
+                        maintain a consistent display for an object that
+                        may have changed since the display was computed.
+
+        u, U            Typing "u" or "U" takes one back up the chain of
+                        investigation, to the object for which this
+                        object was displayed as a component.  This only
+                        works for displays generated by modifying a
+                        previously current display; this does not work
+                        for a display generated as a new inspector
+                        window.
+DONE

=====================================
src/lisp/globals.h
=====================================
--- a/src/lisp/globals.h
+++ b/src/lisp/globals.h
@@ -64,7 +64,7 @@ extern void globals_init(void);
 #define EXTERN(name,bytes) .extern name bytes
 #endif
 #ifdef sparc
-#ifdef SVR4
+#if defined(SVR4) || defined(FEATURE_ELF)
 #define EXTERN(name,bytes) .global name
 #else
 #define EXTERN(name,bytes) .global _ ## name

=====================================
src/lisp/sparc-assem.S
=====================================
--- a/src/lisp/sparc-assem.S
+++ b/src/lisp/sparc-assem.S
@@ -4,43 +4,12 @@
 #include <sys/asm_linkage.h>
 #include <sys/psw.h>
 #include <sys/trap.h>
-#define _current_binding_stack_pointer current_binding_stack_pointer
-#define _current_control_stack_pointer current_control_stack_pointer
-#define _current_dynamic_space_free_pointer current_dynamic_space_free_pointer
-#define _foreign_function_call_active foreign_function_call_active
-#define _current_control_frame_pointer current_control_frame_pointer
-#define _call_into_lisp call_into_lisp
-#define _function_end_breakpoint_end function_end_breakpoint_end
-#define _closure_tramp closure_tramp
-#define _undefined_tramp undefined_tramp
-#define _function_end_breakpoint_trap function_end_breakpoint_trap
-#define _function_end_breakpoint_guts function_end_breakpoint_guts
-#define _call_into_c call_into_c
-#define _flush_icache flush_icache
-#define	_do_pending_interrupt do_pending_interrupt
-#define _do_dynamic_space_overflow_error do_dynamic_space_overflow_error
-#define _do_dynamic_space_overflow_warning do_dynamic_space_overflow_warning
-#ifdef GENCGC
-/*#define _collect_garbage collect_garbage*/
-#define _fpu_save fpu_save
-#define _fpu_restore fpu_restore				
-#endif
-#ifdef LINKAGE_TABLE
-#define _resolve_linkage_tramp resolve_linkage_tramp
-#define	_lazy_resolve_linkage	lazy_resolve_linkage
-#define	_undefined_foreign_symbol_trap	undefined_foreign_symbol_trap
-#endif		
 #ifdef __STDC__
 #define FUNCDEF(x)	.type x, \#function
 #else
 #define FUNCDEF(x)	.type x, #function
 #endif
 #else
-#include <machine/asm_linkage.h>
-#include <machine/psl.h>
-#include <machine/trap.h>
-#define FUNCDEF(x)  /* nothing */
-#define SET_SIZE(x) /* nothing */
 #endif
 
 #define LANGUAGE_ASSEMBLY
@@ -68,9 +37,9 @@
 #define FRAMESIZE (SA(MINFRAME))
 #endif
         .seg    "text"
-        .global _call_into_lisp
-	FUNCDEF(_call_into_lisp)
-_call_into_lisp:
+        .global call_into_lisp
+	FUNCDEF(call_into_lisp)
+call_into_lisp:
         save    %sp, -FRAMESIZE, %sp
 	/* Flush all of C's register windows to the stack. */
 	ta	ST_FLUSH_WINDOWS
@@ -96,15 +65,15 @@ _call_into_lisp:
 	set	pseudo_atomic_Value, reg_ALLOC
 
 	/* Turn off foreign function call. */
-        sethi   %hi(_foreign_function_call_active), reg_NL0
-        st      reg_ZERO, [reg_NL0+%lo(_foreign_function_call_active)]
+        sethi   %hi(foreign_function_call_active), reg_NL0
+        st      reg_ZERO, [reg_NL0+%lo(foreign_function_call_active)]
 
         /* Load the rest of lisp state. */
-        load(_current_dynamic_space_free_pointer, reg_NL0)
+        load(current_dynamic_space_free_pointer, reg_NL0)
 	add	reg_NL0, reg_ALLOC, reg_ALLOC
-        load(_current_binding_stack_pointer, reg_BSP)
-        load(_current_control_stack_pointer, reg_CSP)
-        load(_current_control_frame_pointer, reg_OCFP)
+        load(current_binding_stack_pointer, reg_BSP)
+        load(current_control_stack_pointer, reg_CSP)
+        load(current_control_frame_pointer, reg_OCFP)
 
         /* No longer atomic, and check for interrupt. */
 	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
@@ -147,13 +116,13 @@ lra:
 
         /* Store LISP state */
 	andn	reg_ALLOC, lowtag_Mask, reg_NL1
-        store(reg_NL1,_current_dynamic_space_free_pointer)
-        store(reg_BSP,_current_binding_stack_pointer)
-        store(reg_CSP,_current_control_stack_pointer)
-        store(reg_CFP,_current_control_frame_pointer)
+        store(reg_NL1,current_dynamic_space_free_pointer)
+        store(reg_BSP,current_binding_stack_pointer)
+        store(reg_CSP,current_control_stack_pointer)
+        store(reg_CFP,current_control_frame_pointer)
 
         /* No longer in Lisp. */
-        store(reg_NL1,_foreign_function_call_active)
+        store(reg_NL1,foreign_function_call_active)
 
         /* Were we interrupted? */
 	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
@@ -164,13 +133,13 @@ lra:
 	ld	[%sp+FRAMESIZE-4], %i7
         ret
         restore	%sp, FRAMESIZE, %sp
-	SET_SIZE(_call_into_lisp)
+	SET_SIZE(call_into_lisp)
 
 
 
-        .global _call_into_c
-	FUNCDEF(_call_into_c)
-_call_into_c:
+        .global call_into_c
+	FUNCDEF(call_into_c)
+call_into_c:
 #ifdef v8plus
 	stx	%o2, [%fp - 8 - 1*8]
 	stx	%o3, [%fp - 8 - 2*8]
@@ -195,17 +164,17 @@ _call_into_c:
 	st	reg_L0, [reg_CFP+4]
 
         /* Store LISP state */
-        store(reg_BSP,_current_binding_stack_pointer)
-        store(reg_CSP,_current_control_stack_pointer)
-        store(reg_CFP,_current_control_frame_pointer)
+        store(reg_BSP,current_binding_stack_pointer)
+        store(reg_CSP,current_control_stack_pointer)
+        store(reg_CFP,current_control_frame_pointer)
 
 	/* Use reg_CFP as a work register, and restore it */
 	andn	reg_ALLOC, lowtag_Mask, reg_CFP
-        store(reg_CFP,_current_dynamic_space_free_pointer)
-		load(_current_control_frame_pointer, reg_CFP)
+        store(reg_CFP,current_dynamic_space_free_pointer)
+	load(current_control_frame_pointer, reg_CFP)
 
         /* No longer in Lisp. */
-        store(reg_CSP,_foreign_function_call_active)
+        store(reg_CSP,foreign_function_call_active)
 
         /* Were we interrupted? */
 	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
@@ -229,15 +198,15 @@ _call_into_c:
 	set	pseudo_atomic_Value, reg_ALLOC
 
         /* No longer in foreign function call. */
-        sethi   %hi(_foreign_function_call_active), reg_NL2
-        st      reg_ZERO, [reg_NL2+%lo(_foreign_function_call_active)]
+        sethi   %hi(foreign_function_call_active), reg_NL2
+        st      reg_ZERO, [reg_NL2+%lo(foreign_function_call_active)]
 
         /* Load the rest of lisp state. */
-        load(_current_dynamic_space_free_pointer, reg_NL2)
+        load(current_dynamic_space_free_pointer, reg_NL2)
 	add	reg_NL2, reg_ALLOC, reg_ALLOC
-        load(_current_binding_stack_pointer, reg_BSP)
-        load(_current_control_stack_pointer, reg_CSP)
-        load(_current_control_frame_pointer, reg_CFP)
+        load(current_binding_stack_pointer, reg_BSP)
+        load(current_control_stack_pointer, reg_CSP)
+        load(current_control_frame_pointer, reg_CFP)
 
 	/* Get the return address back. */
 	ld	[reg_CFP+4], reg_LIP
@@ -267,7 +236,7 @@ _call_into_c:
         ret
         nop
 
-	SET_SIZE(_call_into_c)
+	SET_SIZE(call_into_c)
 
 #if 0
 /* undefined_tramp and closure_tramp are now Lisp assembly routines.
@@ -332,8 +301,8 @@ _closure_tramp:
 
 	.text
 	.align	8
-	.global	_function_end_breakpoint_guts
-_function_end_breakpoint_guts:
+	.global	function_end_breakpoint_guts
+function_end_breakpoint_guts:
 	.word	type_ReturnPcHeader
 	b	1f
 	nop
@@ -347,18 +316,18 @@ _function_end_breakpoint_guts:
 	mov	reg_NIL, reg_A5
 1:
 
-	.global	_function_end_breakpoint_trap
-_function_end_breakpoint_trap:
+	.global	function_end_breakpoint_trap
+function_end_breakpoint_trap:
 	unimp	trap_FunctionEndBreakpoint
 	b	1b
 	nop
 
-	.global	_function_end_breakpoint_end
-_function_end_breakpoint_end:
+	.global	function_end_breakpoint_end
+function_end_breakpoint_end:
 
-	.global _flush_icache
-	FUNCDEF(_flush_icache)
-_flush_icache:
+	.global flush_icache
+	FUNCDEF(flush_icache)
+flush_icache:
         add %o0,%o1,%o2
 1:      iflush %o0			! flush instruction cache
         add %o0,8,%o0
@@ -367,34 +336,34 @@ _flush_icache:
         nop
 	retl				! return from leaf routine
         nop
-	SET_SIZE(_flush_icache)
+	SET_SIZE(flush_icache)
 
-        .global _do_pending_interrupt
-	FUNCDEF(_do_pending_interrupt)
-_do_pending_interrupt:
+        .global do_pending_interrupt
+	FUNCDEF(do_pending_interrupt)
+do_pending_interrupt:
 	unimp trap_PendingInterrupt
 	retl
 	nop
-	SET_SIZE(_do_pending_interrupt)
+	SET_SIZE(do_pending_interrupt)
 
 #ifdef trap_DynamicSpaceOverflowError
-	.global _do_dynamic_space_overflow_error
-	FUNCDEF(_do_dynamic_space_overflow_error)
-_do_dynamic_space_overflow_error:	
+	.global do_dynamic_space_overflow_error
+	FUNCDEF(do_dynamic_space_overflow_error)
+do_dynamic_space_overflow_error:	
 	unimp trap_DynamicSpaceOverflowError
 	retl
 	nop
-	SET_SIZE(_do_dynamic_space_overflow_error)		
+	SET_SIZE(do_dynamic_space_overflow_error)		
 #endif				
 
 #ifdef trap_DynamicSpaceOverflowWarning
-	.global _do_dynamic_space_overflow_warning
-	FUNCDEF(_do_dynamic_space_overflow_warning)
-_do_dynamic_space_overflow_warning:	
+	.global do_dynamic_space_overflow_warning
+	FUNCDEF(do_dynamic_space_overflow_warning)
+do_dynamic_space_overflow_warning:	
 	unimp trap_DynamicSpaceOverflowWarning
 	retl
 	nop
-	SET_SIZE(_do_dynamic_space_overflow_warning)		
+	SET_SIZE(do_dynamic_space_overflow_warning)		
 #endif				
 		
 #ifdef LINKAGE_TABLE
@@ -411,10 +380,10 @@ _do_dynamic_space_overflow_warning:
  * registers have been saved, including FP registers.  Hence, no need
  * to save them.
  */
-	.global _lazy_resolve_linkage
-	.global _resolve_linkage_tramp
-	FUNCDEF(_resolve_linkage_tramp)
-_resolve_linkage_tramp:
+	.global lazy_resolve_linkage
+	.global resolve_linkage_tramp
+	FUNCDEF(resolve_linkage_tramp)
+resolve_linkage_tramp:
 	/*
 	 * At this point, all of the global %g registers have been
 	 * saved by call_into_c, so we can use them as temps.  %g2,
@@ -433,7 +402,7 @@ _resolve_linkage_tramp:
 	save	%sp, -FRAMESIZE, %sp
 
 	/* %g2 tells where we came from in the linkage table */
-	call	_lazy_resolve_linkage
+	call	lazy_resolve_linkage
 	mov	reg_NIL, %o0		! in the delay slot
 
 	mov	%o0, reg_NIL
@@ -443,15 +412,15 @@ _resolve_linkage_tramp:
 	jmp	reg_NIL
 	nop
 	
-	SET_SIZE(_resolve_linkage_tramp)						
+	SET_SIZE(resolve_linkage_tramp)						
 		
-	.global _undefined_foreign_symbol_trap
-	FUNCDEF(_undefined_foreign_symbol_trap)
+	.global undefined_foreign_symbol_trap
+	FUNCDEF(undefined_foreign_symbol_trap)
 /*
  * When we get called, %o0 contains the address of the data_vector object 
  * which is a string naming the bad symbol.
  */
-_undefined_foreign_symbol_trap:
+undefined_foreign_symbol_trap:
 	/*
 	   Need to restore all the global registers with the Lisp values that 
 	   were saved away in call_into_c.  (This routine is only called from 
@@ -463,10 +432,10 @@ _undefined_foreign_symbol_trap:
 		
 	*/
 
-	load(_current_dynamic_space_free_pointer, reg_ALLOC)
-        load(_current_binding_stack_pointer, reg_BSP)
-        load(_current_control_stack_pointer, reg_CSP)
-        load(_current_control_frame_pointer, reg_CFP)
+	load(current_dynamic_space_free_pointer, reg_ALLOC)
+        load(current_binding_stack_pointer, reg_BSP)
+        load(current_control_stack_pointer, reg_CSP)
+        load(current_control_frame_pointer, reg_CFP)
 		
 	set	NIL, reg_NIL
 
@@ -493,9 +462,9 @@ _undefined_foreign_symbol_trap:
  * a sparc v9, the Lisp code can actually use all 32 double-float 
  * registers.  For later.
  */
-	.global _fpu_save
-	FUNCDEF(_fpu_save)
-_fpu_save:			
+	.global fpu_save
+	FUNCDEF(fpu_save)
+fpu_save:			
 	std	%f0, [%o0 + 4*0]
 	std	%f2, [%o0 + 4*2]	
 	std	%f4, [%o0 + 4*4]	
@@ -535,11 +504,11 @@ _fpu_save:
 #endif
 	retl
 	nop
-	SET_SIZE(_fpu_save)						
+	SET_SIZE(fpu_save)						
 
-	.global _fpu_restore
-	FUNCDEF(_fpu_restore)
-_fpu_restore:			
+	.global fpu_restore
+	FUNCDEF(fpu_restore)
+fpu_restore:			
 	ldd	[%o0 + 4*0], %f0
 	ldd	[%o0 + 4*2], %f2	
 	ldd	[%o0 + 4*4], %f4	
@@ -579,254 +548,8 @@ _fpu_restore:
 #endif
 	retl
 	nop
-	SET_SIZE(_fpu_restore)						
-
-#ifndef SOLARIS
-
-/****************************************************************\
-* State saving and restoring.
-\****************************************************************/
-
-
-	.global	_call_on_stack
-_call_on_stack:
-	call	%o0
-	sub	%o1, SA(MINFRAME), %sp
-	unimp	0
+	SET_SIZE(fpu_restore)						
 
-	.global	_save_state
-_save_state:
-	save	%sp, -(SA(8*4)+SA(MINFRAME)), %sp
-	ta	ST_FLUSH_WINDOWS
-	st	%i7, [%sp+SA(MINFRAME)]
-	st	%g1, [%sp+SA(MINFRAME)+4]
-	std	%g2, [%sp+SA(MINFRAME)+8]
-	std	%g4, [%sp+SA(MINFRAME)+16]
-	std	%g6, [%sp+SA(MINFRAME)+24]
-	! ### Should also save the FP state.
-	mov	%i1, %o1
-	call	%i0
-	mov	%sp, %o0
-	mov	%o0, %i0
-restore_state:
-	ld	[%sp+SA(MINFRAME)+4], %g1
-	ldd	[%sp+SA(MINFRAME)+8], %g2
-	ldd	[%sp+SA(MINFRAME)+16], %g4
-	ldd	[%sp+SA(MINFRAME)+24], %g6
-	ret
-	restore
-
-	.global	_restore_state
-_restore_state:
-	ta	ST_FLUSH_WINDOWS
-	mov	%o0, %fp
-	mov	%o1, %i0
-	restore
-	ld	[%sp+SA(MINFRAME)], %i7
-	b restore_state
-	mov	%o0, %i0
-
-
-
-/****************************************************************\
-
-We need our own version of sigtramp.
-
-\****************************************************************/
-
-	.global	__sigtramp, __sigfunc
-__sigtramp:
-	!
-	! On entry sp points to:
-	! 	0 - 63: window save area
-	!	64: signal number
-	!	68: signal code
-	!	72: pointer to sigcontext
-	!	76: addr parameter
-	!
-	! A sigcontext looks like:
-#define SC_ONSTACK 0
-#define SC_MASK 4
-#define SC_SP 8
-#define SC_PC 12
-#define SC_NPC 16
-#define SC_PSR 20
-#define SC_G1 24
-#define SC_O0 28
-	!
-	! We change sc_g1 to point to a reg save area:
-#define IREGS_SAVE 0
-#define FPREGS_SAVE (32*4)
-#define Y_SAVE (64*4)
-#define FSR_SAVE (65*4)
-#define REGSAVESIZE (66*4)
-        !
-        ! After we allocate space for the reg save area, the stack looks like:
-        !       < window save area, etc >
-#define REGSAVEOFF SA(MINFRAME)
-#define IREGSOFF REGSAVEOFF+IREGS_SAVE
-#define FPREGSOFF REGSAVEOFF+FPREGS_SAVE
-#define YOFF REGSAVEOFF+Y_SAVE
-#define FSROFF REGSAVEOFF+FSR_SAVE
-#define ORIGSIGNUMOFF REGSAVEOFF+REGSAVESIZE
-#define ORIGCODEOFF ORIGSIGNUMOFF+4
-#define ORIGSCPOFF ORIGSIGNUMOFF+8
-#define ORIGADDROFF ORIGSIGNUMOFF+12
-
-        ! Allocate space for the reg save area.
-        sub     %sp, REGSAVESIZE+SA(MINFRAME)-64, %sp
-
-        ! Save integer registers.
-        ! Note: the globals and outs are good, but the locals and ins have
-        ! been trashed.  But luckly, they have been saved on the stack.
-        ! So we need to extract the saved stack pointer from the sigcontext
-        ! to determine where they are.
-        std     %g0, [%sp+IREGSOFF]
-        std     %g2, [%sp+IREGSOFF+8]
-        std     %g4, [%sp+IREGSOFF+16]
-        std     %g6, [%sp+IREGSOFF+24]
-        std     %o0, [%sp+IREGSOFF+32]
-        std     %o2, [%sp+IREGSOFF+40]
-        ld      [%sp+ORIGSCPOFF], %o2
-	ld	[%o2+SC_SP], %o0
-        std     %o4, [%sp+IREGSOFF+48]
-        st      %o0, [%sp+IREGSOFF+56]
-        st      %o7, [%sp+IREGSOFF+60]
-
-        ldd     [%o0], %l0
-        ldd     [%o0+8], %l2
-        ldd     [%o0+16], %l4
-        ldd     [%o0+24], %l6
-        ldd     [%o0+32], %i0
-        ldd     [%o0+40], %i2
-        ldd     [%o0+48], %i4
-        ldd     [%o0+56], %i6
-        std     %l0, [%sp+IREGSOFF+64]
-        std     %l2, [%sp+IREGSOFF+72]
-        std     %l4, [%sp+IREGSOFF+80]
-        std     %l6, [%sp+IREGSOFF+88]
-        std     %i0, [%sp+IREGSOFF+96]
-        std     %i2, [%sp+IREGSOFF+104]
-        std     %i4, [%sp+IREGSOFF+112]
-        std     %i6, [%sp+IREGSOFF+120]
-
-        ! Check to see if we need to save the fp regs.
-	ld	[%o2+SC_PSR], %l5	! get psr
-	set	PSR_EF, %l0
-	mov	%y, %l2			! save y
-	btst	%l0, %l5		! is FPU enabled?
-	bz	1f			! if not skip FPU save
-	st	%l2, [%sp + YOFF]
-
-	! save all fpu registers.
-	std	%f0, [%sp+FPREGSOFF+(0*4)]
-	std	%f2, [%sp+FPREGSOFF+(2*4)]
-	std	%f4, [%sp+FPREGSOFF+(4*4)]
-	std	%f6, [%sp+FPREGSOFF+(6*4)]
-	std	%f8, [%sp+FPREGSOFF+(8*4)]
-	std	%f10, [%sp+FPREGSOFF+(10*4)]
-	std	%f12, [%sp+FPREGSOFF+(12*4)]
-	std	%f14, [%sp+FPREGSOFF+(14*4)]
-	std	%f16, [%sp+FPREGSOFF+(16*4)]
-	std	%f18, [%sp+FPREGSOFF+(18*4)]
-	std	%f20, [%sp+FPREGSOFF+(20*4)]
-	std	%f22, [%sp+FPREGSOFF+(22*4)]
-	std	%f24, [%sp+FPREGSOFF+(24*4)]
-	std	%f26, [%sp+FPREGSOFF+(26*4)]
-	std	%f28, [%sp+FPREGSOFF+(28*4)]
-	std	%f30, [%sp+FPREGSOFF+(30*4)]
-	st	%fsr, [%sp+FSROFF] ! save old fsr
-1:
-
-	ld	[%sp+ORIGSIGNUMOFF], %o0! get signal number
-	set	__sigfunc, %g1		! get array of function ptrs
-	sll	%o0, 2, %g2		! scale signal number for index
-	ld	[%g1+%g2], %g1		! get func
-	ld	[%sp+ORIGCODEOFF], %o1	! get code
-	! %o2 is already loaded with scp
-	add	%sp, REGSAVEOFF, %o3	! compute pointer to reg save area
-	st	%o3, [%o2 + SC_G1]	! save in sc_g1.
-	call	%g1			! (*_sigfunc[sig])(sig,code,scp,addr)
-	ld	[%sp+ORIGADDROFF], %o3	! get addr
-
-        ! Recompute scp, and drop into _sigreturn
-        ld	[%sp+ORIGSCPOFF], %o0	! get scp
-
-        .global _sigreturn
-_sigreturn:
-	! Load g1 with addr of reg save area (from sc_g1)
-	ld	[%o0+SC_G1], %g1
-
-        ! Move values we cannot restore directory into real sigcontext.
-        ld      [%g1+IREGS_SAVE+(4*1)], %l0	! g1
-        ld      [%g1+IREGS_SAVE+(4*8)], %l1	! o0
-        ld      [%g1+IREGS_SAVE+(4*14)], %l2	! sp
-        st      %l0, [%o0+SC_G1]
-        st      %l1, [%o0+SC_O0]
-        st      %l2, [%o0+SC_SP]
-
-	ld	[%o0+SC_PSR], %l2	! get psr
-	set	PSR_EF, %l0
-	ld	[%g1+Y_SAVE], %l1	! restore y
-	btst	%l0, %l2		! is FPU enabled?
-	bz	2f			! if not skip FPU restore
-	mov	%l1, %y
-
-	ldd	[%g1+FPREGS_SAVE+(0*4)], %f0	! restore all fpu registers.
-	ldd	[%g1+FPREGS_SAVE+(2*4)], %f2
-	ldd	[%g1+FPREGS_SAVE+(4*4)], %f4
-	ldd	[%g1+FPREGS_SAVE+(6*4)], %f6
-	ldd	[%g1+FPREGS_SAVE+(8*4)], %f8
-	ldd	[%g1+FPREGS_SAVE+(10*4)], %f10
-	ldd	[%g1+FPREGS_SAVE+(12*4)], %f12
-	ldd	[%g1+FPREGS_SAVE+(14*4)], %f14
-	ldd	[%g1+FPREGS_SAVE+(16*4)], %f16
-	ldd	[%g1+FPREGS_SAVE+(18*4)], %f18
-	ldd	[%g1+FPREGS_SAVE+(20*4)], %f20
-	ldd	[%g1+FPREGS_SAVE+(22*4)], %f22
-	ldd	[%g1+FPREGS_SAVE+(24*4)], %f24
-	ldd	[%g1+FPREGS_SAVE+(26*4)], %f26
-	ldd	[%g1+FPREGS_SAVE+(28*4)], %f28
-	ldd	[%g1+FPREGS_SAVE+(30*4)], %f30
-	ld	[%g1+FSR_SAVE], %fsr	! restore old fsr
-2:
-
-	! The locals and in are restored from the stack, so we have to put
-	! them there.
-	ld	[%o0+SC_SP], %o1
-        ldd     [%g1+IREGS_SAVE+(16*4)], %l0
-        ldd     [%g1+IREGS_SAVE+(18*4)], %l2
-        ldd     [%g1+IREGS_SAVE+(20*4)], %l4
-        ldd     [%g1+IREGS_SAVE+(22*4)], %l6
-        ldd     [%g1+IREGS_SAVE+(24*4)], %i0
-        ldd     [%g1+IREGS_SAVE+(26*4)], %i2
-        ldd     [%g1+IREGS_SAVE+(28*4)], %i4
-        ldd     [%g1+IREGS_SAVE+(30*4)], %i6
-	std	%l0, [%o1+(0*4)]
-	std	%l2, [%o1+(2*4)]
-	std	%l4, [%o1+(4*4)]
-	std	%l6, [%o1+(6*4)]
-	std	%i0, [%o1+(8*4)]
-	std	%i2, [%o1+(10*4)]
-	std	%i4, [%o1+(12*4)]
-	std	%i6, [%o1+(14*4)]
-
-        ! Restore the globals and outs.  Do not restore %g1, %o0, or %sp
-	! because they get restored from the sigcontext.
-        ldd     [%g1+IREGS_SAVE+(2*4)], %g2
-        ldd     [%g1+IREGS_SAVE+(4*4)], %g4
-        ldd     [%g1+IREGS_SAVE+(6*4)], %g6
-        ld      [%g1+IREGS_SAVE+(9*4)], %o1
-        ldd     [%g1+IREGS_SAVE+(10*4)], %o2
-        ldd     [%g1+IREGS_SAVE+(12*4)], %o4
-        ld      [%g1+IREGS_SAVE+(15*4)], %o7
-
-	set	139, %g1		! sigcleanup system call
-	t	0
-	unimp	0			! just in case it returns
-	/*NOTREACHED*/
-
-#else /* SOLARIS */
 	.global save_context
 	FUNCDEF(save_context)
 save_context:
@@ -834,8 +557,6 @@ save_context:
 	retl				! return from leaf routine
 	nop
 	SET_SIZE(save_context)
-
-#endif
 /*
  * Local variables:
  * tab-width: 8


View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b038df8de36e85365670a50bc...

    

Raymond Toy

tags

participants (1)