From 7a90c40292b0cd6770376149e9d2374d4abbf8c2 Mon Sep 17 00:00:00 2001
From: garland <garland>
Date: Thu, 12 Nov 1992 14:08:52 +0000
Subject: [PATCH] Initial revision

---
 interface/debug.lisp     | 446 ++++++++++++++++++++++++
 interface/initial.lisp   |  16 +
 interface/inspect.lisp   | 502 +++++++++++++++++++++++++++
 interface/interface.lisp | 721 +++++++++++++++++++++++++++++++++++++++
 4 files changed, 1685 insertions(+)
 create mode 100644 interface/debug.lisp
 create mode 100644 interface/initial.lisp
 create mode 100644 interface/inspect.lisp
 create mode 100644 interface/interface.lisp

diff --git a/interface/debug.lisp b/interface/debug.lisp
new file mode 100644
index 000000000..b2e377fc4
--- /dev/null
+++ b/interface/debug.lisp
@@ -0,0 +1,446 @@
+;;;; -*- Mode: Lisp ; Package: Debug -*-
+;;;
+
+(in-package "DEBUG")
+(use-package '("TOOLKIT" "INTERFACE"))
+
+(defvar *current-debug-display* nil)
+(defvar *debug-active-frames* nil)
+(defvar *old-display-frames* nil)
+
+
+
+;;;; Structures used by the graphical debugger
+
+(defstruct (debug-display
+	    (:conc-name dd-info-)
+	    (:print-function print-debug-display)
+	    (:constructor make-debug-display
+			  (debug-pane restarts backtrace)))
+  (debug-pane nil :type (or null widget))
+  (restarts nil :type (or null widget))
+  (backtrace nil :type (or null widget))
+  (level 0 :type fixnum)
+  (connection nil :type (or null xt::motif-connection)))
+
+(defun print-debug-display (info stream d)
+  (declare (ignore d))
+  (format stream "#<Debugger Display Info level ~d" (dd-info-level info)))
+
+
+
+;;;; Callback functions
+
+(defun quit-debugger-callback (widget call-data condition)
+  (declare (ignore widget call-data))
+  (close-motif-debugger condition)
+  (throw 'lisp::top-level-catcher nil))
+
+(defun restart-callback (widget call-data restart)
+  (declare (ignore widget call-data))
+  (invoke-restart-interactively restart))
+
+(defun stack-frame-callback (widget call-data frame)
+  (declare (ignore widget call-data))
+  (unless (assoc frame *debug-active-frames*)
+    ;; Should wrap this in a busy cursor
+    (debug-display-frame frame)))
+
+(defun ping-callback (widget call-data test)
+  (declare (ignore widget call-data))
+  (destroy-widget (car (xt::widget-children test))))
+
+(defun close-all-callback (widget call-data)
+  (declare (ignore widget call-data))
+  (dolist (info *debug-active-frames*)
+    (destroy-widget (cdr info)))
+  (setf *debug-active-frames* nil))
+
+(defun frame-view-callback (widget call-data thing)
+  (declare (ignore widget call-data))
+  ;; Should wrap this in a busy cursor
+  (inspect thing))
+
+(defun close-frame-callback (widget call-data frame)
+  (declare (ignore widget call-data))
+  (setf *debug-active-frames*
+	(delete frame *debug-active-frames*
+		:test #'(lambda (a b) (eql a (car b)))))
+  (destroy-interface-pane frame))
+
+(defun edit-source-callback (widget call-data)
+  (declare (ignore widget call-data))
+  (funcall (debug-command-p :edit-source)))
+
+(defun frame-eval-callback (widget call-data frame output)
+  (declare (ignore call-data))
+  (let* ((input (car (get-values widget :value)))
+	 (mark (text-get-last-position output))
+	 (response
+	  (format nil "Eval>> ~a~%~a--------------------~%"
+		  input
+		  (handler-case
+		      (multiple-value-bind
+			  (out val)
+			  (let ((*current-frame* frame))
+			    (grab-output-as-string
+			     (di:eval-in-frame frame (read-from-string input))))
+			(format nil "~a~s~%" out val))
+		    (error (cond)
+			   (format nil "~2&~A~2&" cond)))))
+	  (length (length response)))
+    (declare (simple-string response))
+	
+    (text-set-string widget "")
+    (text-insert output mark response)
+    ;; This is to make sure that things stay visible
+    (text-set-insertion-position output (+ length mark))))
+
+(defun source-verbosity-callback (widget call-data frame srcview delta)
+  (declare (ignore widget call-data))
+  (let* ((current (car (get-values srcview :user-data)))
+	 (new (+ current delta)))
+    (when (minusp new)
+      (setf new 0))
+    (let ((source (handler-case
+		     (grab-output-as-string
+		      (print-code-location-source-form
+		       (di:frame-code-location frame) new))
+		   (di:debug-condition (cond)
+		     (declare (ignore cond))
+		     "Source form not available."))))
+      (set-values srcview
+		  :label-string source
+		  :user-data new))))
+
+
+
+(defun debug-display-frame-locals (frame debug-fun location frame-view)
+  (let (widgets)
+    (if (di:debug-variable-info-available debug-fun)
+	(let ((any-p nil)
+	      (any-valid-p nil))
+	  (di:do-debug-function-variables (v debug-fun)
+	    (unless any-p
+	      (setf any-p t)
+	      (push (create-label-gadget frame-view "localsLabel"
+					 :font-list *header-font*
+					 :label-string "Local variables:")
+		    widgets))
+	    (when (eq (di:debug-variable-validity v location) :valid)
+	      (let ((value (di:debug-variable-value v frame))
+		    (id (di:debug-variable-id v)))
+		(setf any-valid-p t)
+		(push
+		 (create-value-box frame-view
+				   (format nil "   ~A~:[#~D~;~*~]:"
+					   (di:debug-variable-name v)
+					   (zerop id) id)
+				   value
+				   :callback 'frame-view-callback)
+		 widgets))))
+	  (cond
+	   ((not any-p)
+	    (push
+	     (create-label-gadget frame-view "noLocals"
+				  :font-list *italic-font*
+				  :label-string
+				  "   No local variables in function.")
+	     widgets))
+	   ((not any-valid-p)
+	    (push
+	     (create-label-gadget frame-view "noValidLocals"
+				  :font-list *italic-font*
+				  :label-string
+				  "   All variables have invalid values.")
+	     widgets))))
+
+	(push (create-label-gadget frame-view "noVariableInfo"
+				   :font-list *italic-font*
+				   :label-string
+				   "   No variable information available.")
+	      widgets))
+    (apply #'manage-children widgets)))
+
+(defun debug-display-frame-prompt (frame frame-view)
+  (let* ((form (create-form frame-view "promptForm"))
+	 (label (create-label-gadget form "framePrompt"
+				     :label-string "Frame Eval:"
+				     :font-list *header-font*))
+	 (entry (create-text form "frameEval"
+			     :top-attachment :attach-widget
+			     :top-widget label
+			     :left-attachment :attach-form
+			     :right-attachment :attach-form))
+	 (output (create-text form "frameOutput"
+			      :edit-mode :multi-line-edit
+			      :editable nil
+			      :rows 8
+			      :columns 40
+			      :top-attachment :attach-widget
+			      :top-widget entry
+			      :bottom-attachment :attach-form
+			      :left-attachment :attach-form
+			      :right-attachment :attach-form)))
+
+    (manage-child form)
+    (manage-children label entry output)
+    (add-callback entry :activate-callback 'frame-eval-callback
+		  frame output)))
+
+(defun debug-display-frame (frame)
+  (let* ((debug-fun (di:frame-debug-function frame))
+	 (location (di:frame-code-location frame))
+	 (name (di:debug-function-name debug-fun))
+	 (title (format nil "Stack Frame: ~A" name))
+	 (frame-shell (create-interface-pane-shell title frame))
+	 (frame-view (create-row-column frame-shell "debugFrameView"))
+	 (menu-bar (create-menu-bar frame-view "frameMenu"))
+	 (fcall (create-label-gadget frame-view "frameCall"
+				     :label-string
+				     (format nil "Frame Call: ~a"
+					     (grab-output-as-string
+					      (print-frame-call frame)))))
+	 (fbox (create-value-box frame-view "Function:"
+				 name
+				 :callback 'frame-view-callback
+				 :client-data
+				 (di:debug-function-function debug-fun)))
+	 (slabel (create-label-gadget frame-view "sourceLabel"
+				      :font-list *header-font*
+				      :label-string "Source form:"))
+	 (swindow (create-scrolled-window frame-view "frameSourceWindow"
+					  :scrolling-policy :automatic
+					  :scroll-bar-placement :bottom-right))
+
+	 (source (handler-case
+		     (grab-output-as-string
+		      (print-code-location-source-form location 0))
+		   (di:debug-condition (cond)
+		     (declare (ignore cond))
+		     "Source form not available.")))
+	 (srcview (create-label-gadget swindow "sourceForm"
+				       :alignment :alignment-beginning
+				       :user-data 0
+				       :label-string source))
+	 (cascade1
+	  (create-interface-menu menu-bar "Frame"
+	   `(("Edit Source" edit-source-callback)
+	     ("Expand Source Form" source-verbosity-callback ,frame ,srcview 1)
+	     ("Shrink Source Form" source-verbosity-callback ,frame ,srcview -1)
+	     ("Close Frame" close-frame-callback ,frame))))
+	 (cascade2 (create-cached-menu menu-bar "Debug")))
+
+    (manage-child frame-view)
+    (manage-children menu-bar fcall fbox slabel swindow)
+    (manage-child srcview)
+    (manage-children cascade1 cascade2)
+
+    (debug-display-frame-locals frame debug-fun location frame-view)
+    (debug-display-frame-prompt frame frame-view)
+
+    (popup-interface-pane frame-shell)
+    (push (cons frame frame-shell) *debug-active-frames*)))
+
+
+
+;;;; Functions to display the debugger control panel
+
+(defun debug-display-error (errmsg condition)
+  (set-values errmsg :label-string (format nil "~A" condition)))
+
+(defun debug-display-restarts (restarts)
+  (let (buttons)
+    (dolist (r *debug-restarts*)
+      (let ((button (create-highlight-button
+		     restarts "restartButton" (format nil "~A" r))))
+	(add-callback button :activate-callback 'restart-callback r)
+	(push button buttons)))
+    (apply #'manage-children buttons)))
+
+(defun debug-display-stack (backtrace)
+  (let ((buttons))
+    (do ((frame *current-frame* (di:frame-down frame)))
+	((null frame))
+      (let ((button (create-highlight-button
+		     backtrace "stackFrame"
+		     (grab-output-as-string
+		      (print-frame-call frame)))))
+	(add-callback button :activate-callback 'stack-frame-callback frame)
+	(push button buttons)))
+    (apply #'manage-children buttons)))
+
+(defun create-debugger (condition)
+  (let* ((debug-pane (create-interface-pane-shell "Debugger" condition))
+	 (frame (create-frame debug-pane "debugFrame"))
+	 (form (create-form frame "debugForm"))
+	 (menu-bar (create-menu-bar form "debugMenu"
+				    :left-attachment :attach-form
+				    :right-attachment :attach-form))
+	 (cascade (create-cached-menu
+		   menu-bar "Debug"
+		   `(("Close All Frames" close-all-callback)
+		     ("Quit Debugger" quit-debugger-callback ,condition))))
+ 	 (errlabel (create-label-gadget form "errorLabel"
+					:top-attachment :attach-widget
+					:top-widget menu-bar
+					:left-attachment :attach-form
+					:font-list *header-font*
+					:label-string "Error Message:"))
+	 (errmsg (create-label-gadget form "errorMessage"
+				      :top-attachment :attach-widget
+				      :top-widget errlabel
+				      :left-attachment :attach-form
+				      :right-attachment :attach-form))
+	 (rlabel (create-label-gadget form "restartLabel"
+				      :top-attachment :attach-widget
+				      :top-widget errmsg
+				      :left-attachment :attach-form
+				      :font-list *header-font*))
+	 (restarts (create-row-column form "debugRestarts"
+				      :adjust-last nil
+				      :top-attachment :widget
+				      :top-widget rlabel
+				      :left-attachment :attach-form
+				      :right-attachment :attach-form
+				      :left-offset 10))
+	 (btlabel (create-label-gadget form "backtraceLabel"
+				       :label-string "Stack Backtrace:"
+				       :font-list *header-font*
+				       :top-attachment :attach-widget
+				       :top-widget restarts
+				       :left-attachment :attach-form))
+	 (btwindow (create-scrolled-window form "backtraceWindow"
+					   :scrolling-policy :automatic
+					   :scroll-bar-placement :bottom-right
+					   :left-attachment :attach-form
+					   :right-attachment :attach-form
+					   :left-offset 4
+					   :right-offset 4
+					   :bottom-offset 4
+					   :bottom-attachment :attach-form
+					   :top-attachment :attach-widget
+					   :top-widget btlabel))
+	 (backtrace (create-row-column btwindow "debugBacktrace"
+				       :adjust-last nil
+				       :spacing 1)))
+
+    (manage-child frame) (manage-child form)
+    (manage-children menu-bar errlabel errmsg rlabel restarts btlabel btwindow)
+    (manage-child backtrace)
+    (manage-child cascade)
+
+    (debug-display-error errmsg condition)
+    
+    (if *debug-restarts*
+	(progn
+	  (set-values rlabel :label-string "Restarts:")
+	  (debug-display-restarts restarts))
+	(set-values rlabel :label-string "No restarts available"))
+
+    (debug-display-stack backtrace)
+
+    (setf *current-debug-display*
+	  (make-debug-display debug-pane restarts backtrace))
+
+    (popup-interface-pane debug-pane)
+    debug-pane))
+    
+(defun close-motif-debugger (condition)
+  (push *current-debug-display* *old-display-frames*)
+  ;;
+  ;; Destroy all frame panes
+  (dolist (info *debug-active-frames*)
+    (destroy-widget (cdr info)))
+  (setf *debug-active-frames* nil)
+  ;;
+  ;; Destroy the restart/backtrace window
+  (setf *current-debug-display* nil)
+  (destroy-interface-pane condition)
+
+  (format t "Leaving debugger.~%"))
+
+(defun invoke-motif-debugger (condition)
+  (let* ((frame (di:top-frame))
+	 (previous-display *current-debug-display*)
+	 (*current-debug-display* nil)
+	 (*debug-active-frames* nil))
+    (declare (ignore previous-display))
+    (verify-system-server-exists)
+    (multiple-value-bind (shell connection)
+			 (create-interface-shell)
+      (declare (ignore shell))
+      (with-motif-connection (connection)
+	(let ((pane (find-interface-pane condition))
+	      (*current-frame* frame))
+	  (unless pane
+	    (setf pane (create-debugger condition)))
+	  (unless (is-managed pane)
+	    (popup-interface-pane pane))
+	  (setf (dd-info-level *current-debug-display*) *debug-command-level*)
+	  (setf (dd-info-connection *current-debug-display*) connection)
+	  (unwind-protect
+	      (handler-case
+		  (loop
+		    (system:serve-event))
+		(error (err)
+		       (if *flush-debug-errors*
+			   (interface-error (format nil "~a" err) pane)
+			   (interface-error
+			    "Do not yet support recursive debugging" pane))))
+	    (when (and connection *current-debug-display*)
+	      (with-motif-connection (connection)
+		(close-motif-debugger condition)))))))))
+
+
+
+(defun invoke-debugger (condition)
+  "The CMU Common Lisp debugger.  Type h for help."
+  (when *debugger-hook*
+    (let ((hook *debugger-hook*)
+	  (*debugger-hook* nil))
+      (funcall hook condition hook)))
+  (unix:unix-sigsetmask 0)
+  (let* ((*debug-condition* condition)
+	 (*debug-restarts* (compute-restarts))
+	 (*standard-input* *debug-io*)          ;in case of setq
+	 (*standard-output* *debug-io*)         ;''  ''  ''  ''
+	 (*error-output* *debug-io*)
+	 ;; Rebind some printer control variables.
+	 (kernel:*current-level* 0)
+	 (*print-readably* nil)
+	 (*read-eval* t))
+    (if (or (not (use-graphics-interface))
+	    (typep condition 'xti:toolkit-error))
+	(progn
+	  (format *error-output* "~2&~A~2&" *debug-condition*)
+	  (unless (typep condition 'step-condition)
+	    (show-restarts *debug-restarts* *error-output*))
+	  (internal-debug))
+	(progn
+	  (write-line "Invoking debugger...")
+	  (invoke-motif-debugger condition)))))
+
+#|
+(defun invoke-debugger (condition)
+  "The CMU Common Lisp debugger.  Type h for help."
+  (when *debugger-hook*
+    (let ((hook *debugger-hook*)
+	  (*debugger-hook* nil))
+      (funcall hook condition hook)))
+  (unix:unix-sigsetmask 0)
+  (let* ((*debug-condition* condition)
+	 (*debug-restarts* (compute-restarts))
+	 (*standard-input* *debug-io*)          ;in case of setq
+	 (*standard-output* *debug-io*)         ;''  ''  ''  ''
+	 (*error-output* *debug-io*)
+	 ;; Rebind some printer control variables.
+	 (kernel:*current-level* 0)
+	 (*print-readably* nil)
+	 (*read-eval* t))
+    (format *error-output* "~2&~A~2&" *debug-condition*)
+    (unless (typep condition 'step-condition)
+      (show-restarts *debug-restarts* *error-output*))
+    (internal-debug)))
+
+|#
diff --git a/interface/initial.lisp b/interface/initial.lisp
new file mode 100644
index 000000000..1dacb1207
--- /dev/null
+++ b/interface/initial.lisp
@@ -0,0 +1,16 @@
+;;;; -*- Mode: Lisp ; Package: User -*-
+;;;
+
+(in-package "USER")
+
+(defpackage "INTERFACE"
+  (:use "TOOLKIT" "LISP" "PCL" "EXTENSIONS" "KERNEL")
+  (:export "*HEADER-FONT*" "*ITALIC-FONT*" "*ENTRY-FONT*" "*INTERFACE-STYLE*"
+	   "USE-GRAPHICS-INTERFACE" "VERIFY-SYSTEM-SERVER-EXISTS"
+	   "CREATE-INTERFACE-SHELL" "POPUP-INTERFACE-PANE"
+	   "CREATE-INTERFACE-PANE-SHELL" "FIND-INTERFACE-PANE"
+	   "DESTROY-INTERFACE-PANE" "CREATE-HIGHLIGHT-BUTTON" "CREATE-VALUE-BOX"
+	   "SET-VALUE-BOX" "WITH-WIDGET-CHILDREN" "INTERFACE-ERROR"
+	   "PRINT-FOR-WIDGET-DISPLAY" "WITH-BUSY-CURSOR"
+	   "CREATE-INTERFACE-MENU" "CREATE-CACHED-MENU"
+	   "GRAB-OUTPUT-AS-STRING" "*ALL-FONTS*" "LISP-CONTROL-PANEL"))
diff --git a/interface/inspect.lisp b/interface/inspect.lisp
new file mode 100644
index 000000000..f8b407bfa
--- /dev/null
+++ b/interface/inspect.lisp
@@ -0,0 +1,502 @@
+;;;; -*- Mode: Lisp ; Package: Interface -*-
+;;;
+;;;
+
+(in-package "INTERFACE")
+
+
+(defvar *inspector-huge-object-threshold* 20)
+(defvar *inspector-sequence-initial-display* 5)
+
+
+
+;;;; Inspector callbacks
+
+(defun destroy-pane-callback (widget call-data object)
+  (declare (ignore widget call-data))
+  (destroy-interface-pane object))
+
+(defun inspect-object-callback (widget call-data object)
+  (declare (ignore widget call-data))
+  (inspect object))
+
+(defun inspect-eval-callback (widget call-data output shell)
+  (declare (ignore widget call-data))
+  (with-busy-cursor (shell)
+    (inspect (xti:widget-user-data output))))
+
+(defun eval-callback (widget call-data object output)
+  (declare (ignore call-data))
+  (let* ((input (car (get-values widget :value)))
+	 (mark (text-get-last-position output))
+	 (response
+	  (format nil "* ~a~%~a~%"
+		  input
+		  (handler-case
+		      (multiple-value-bind (out val)
+					   (grab-output-as-string
+					    (let ((* object))
+					      (eval (read-from-string input))))
+			(setf (xti:widget-user-data output) val)
+			(format nil "~a~s~%" out val))
+		    (error (cond)
+		      (format nil "~2&~A~2&" cond)))))
+	 (length (length response)))
+    (declare (simple-string response))
+
+    (text-set-string widget "")
+    (text-insert output mark response)
+    (text-set-insertion-position output (+ length mark))))
+
+(defun popup-eval-callback (widget call-data pane object)
+  (declare (ignore widget call-data))
+  (multiple-value-bind (form shell)
+		       (create-form-dialog pane "evalDialog")
+    (let* ((s1 (compound-string-create "Eval: " "HeaderFont"))
+	   (s2 (compound-string-create
+		(format nil "[~a]" (print-for-widget-display "~S" object))
+		"EntryFont"))
+	   (s3 (compound-string-concat s1 s2))
+	   (done (create-push-button-gadget form "evalDone"
+					    :label-string "Done"
+					    :bottom-attachment :attach-form))
+	   (inspect (create-push-button-gadget form "evalInspect"
+					       :label-string "Inspect Last"
+					       :bottom-attachment :attach-form
+					       :left-attachment :attach-widget
+					       :left-widget done))
+	   (entry (create-text form "evalEntry"
+			       :bottom-attachment :attach-widget
+			       :bottom-widget done
+			       :left-attachment :attach-form
+			       :right-attachment :attach-form))
+	   (prompt (create-label-gadget form "evalPrompt"
+					:bottom-attachment :attach-widget
+					:bottom-widget entry
+					:font-list *all-fonts*
+					:label-string s3))
+	   (output (create-text form "evalOutput"
+				:edit-mode :multi-line-edit
+				:editable nil
+				:rows 8
+				:columns 40
+				:top-attachment :attach-form
+				:bottom-attachment :attach-widget
+				:bottom-widget prompt
+				:left-attachment :attach-form
+				:right-attachment :attach-form)))
+      (compound-string-free s1)
+      (compound-string-free s2)
+
+      (set-values shell :title "Inspector Eval"
+		        :keyboard-focus-policy :pointer)
+      (add-callback entry :activate-callback 'eval-callback object output)
+      (add-callback inspect :activate-callback
+		    'inspect-eval-callback output shell)
+      (add-callback done :activate-callback #'destroy-callback shell)
+      (manage-children done inspect entry prompt output)
+      (manage-child form))))
+
+
+
+;;;; Methods for constructing the title of inspection panes
+
+(defmethod inspector-pane-title (object)
+  (typecase object
+    (pcl::std-instance
+     (format nil "Instance ~a of Class ~a"
+	     object (pcl:class-name (pcl:class-of object))))
+    (function (format nil "~a" object))
+    (structure
+     (let ((default (format nil "~a" object)))
+       (declare (simple-string default))
+       (if (and (> (length default) 2)
+		(char= (schar default 0) #\#)
+		(char= (schar default 1) #\S))
+	   (format nil "#<~a Structure>" (type-of object))
+	   default)))
+    (t
+     (format nil "~a ~a" (string-capitalize (type-of object))
+	     (print-for-widget-display "~s" object)))))
+
+(defmethod inspector-pane-title ((sym symbol))
+  (format nil "Symbol ~s" sym))
+
+(defmethod inspector-pane-title ((v vector))
+  (declare (vector v))
+  (let ((length (length v))
+	(type (type-of v)))
+    (format nil "~a of length ~a"
+	    (string-capitalize (if (listp type) (car type) type))
+	    length)))
+
+(defmethod inspector-pane-title ((a array))
+  (let ((dimensions (array-dimensions a)))
+    (format nil "Array of ~a  Dimensions = ~s"
+	    (array-element-type a) dimensions)))
+
+(defmethod inspector-pane-title ((l list))
+  (if (not (listp (cdr l)))
+      (format nil "Dotted Pair")
+      (format nil "List of length ~a" (length l))))
+
+
+
+;;;; Methods for displaying object inspection panes
+
+(defmacro with-inspector-pane ((object) &body forms)
+  `(multiple-value-bind
+       (pane is-new)
+       (create-interface-pane-shell (format nil "Inspect: ~a" (type-of ,object))
+				    ,object)
+     (when is-new
+       (let* ((frame (create-frame pane "inspectFrame"))
+	      (over-form (create-form frame "inspectForm"))
+	      (menu-bar (create-menu-bar over-form "menubar"
+					 :left-attachment :attach-form
+					 :right-attachment :attach-form))
+	      (obmenu (create-interface-menu
+		       menu-bar "Object"
+		       ,``(("Eval Expression" popup-eval-callback ,pane ,,object)
+			   ("Close Pane" destroy-pane-callback ,,object))))
+	      (title (create-label-gadget
+		      over-form "inspectTitle"
+		      :label-string (inspector-pane-title ,object)
+		      :font-list *header-font*
+		      :top-attachment :attach-widget
+		      :top-widget menu-bar
+		      :left-attachment :attach-form
+		      :right-attachment :attach-form))
+	      (form (create-form over-form "inspectForm"
+				 :left-attachment :attach-form
+				 :right-attachment :attach-form
+				 :bottom-attachment :attach-form
+				 :top-attachment :attach-widget
+				 :top-widget title)))
+
+	 ,@forms
+	 (manage-child frame)
+	 (manage-child over-form)
+	 (manage-child obmenu)
+	 (manage-children menu-bar title form)))
+     (popup-interface-pane pane)))
+
+(defmethod display-inspector-pane (object)
+  (typecase object
+    (pcl::std-instance (display-clos-pane object))
+    (function (display-function-pane object))
+    (structure (display-structure-pane object))
+    (t
+     (with-inspector-pane (object)
+       (let ((label (create-label-gadget
+		     form "label"
+		     :label-string (format nil "~s" object))))
+	 (manage-child label))))))
+
+
+(defmethod display-inspector-pane ((sym symbol))
+  (with-inspector-pane (sym)
+    (let* ((value (if (boundp sym) (symbol-value sym) "Unbound"))
+	   (function (if (fboundp sym) (symbol-function sym) "Undefined"))
+	   (plist (symbol-plist sym))
+	   (package (symbol-package sym))
+	   (rc (create-row-column form "rowColumn"))
+	   (vview (create-value-box rc "Value:" value
+				    :callback 'inspect-object-callback
+				    :activep (boundp sym)))
+	   (fview (create-value-box rc "Function:" function
+				    :callback 'inspect-object-callback
+				    :activep (fboundp sym)))
+	   (plview (create-value-box rc "PList:" plist
+				     :callback 'inspect-object-callback))
+	   (pview (create-value-box rc "Package:" package
+				    :callback 'inspect-object-callback)))
+      (manage-child rc)
+      (manage-children vview fview plview pview))))
+
+(defun is-traced (function)
+  (let ((fun (debug::trace-fdefinition function)))
+    (if (gethash fun debug::*traced-functions*) t)))
+
+(defun trace-function-callback (widget call-data function)
+  (declare (ignore widget))
+  (if (toggle-button-callback-set call-data)
+      (debug::trace-1 function (debug::make-trace-info))
+      (debug::untrace-1 function)))
+
+(defun display-function-pane (f)
+  (with-inspector-pane (f)
+    (multiple-value-bind
+	(dstring dval)
+	(grab-output-as-string (describe f))
+      (declare (ignore dval))
+      (let* ((trace (create-toggle-button-gadget form "functionTrace"
+						 :bottom-attachment :attach-form
+						 :label-string "Trace Function"
+						 :set (is-traced f)))
+	     (sep (create-separator-gadget form "separator"
+					   :left-attachment :attach-form
+					   :right-attachment :attach-form
+					   :bottom-attachment :attach-widget
+					   :bottom-widget trace))
+	     (descview (create-scrolled-window form "scrolledView"
+					       :left-attachment :attach-form
+					       :right-attachment :attach-form
+					       :bottom-attachment :attach-widget
+					       :bottom-widget sep
+					       :top-attachment :attach-form
+					       :scrolling-policy :automatic))
+	     (desc (create-label descview "functionDescription"
+				 :alignment :alignment-beginning
+				 :label-string dstring)))
+
+	(add-callback trace :value-changed-callback
+		      'trace-function-callback f)
+	(manage-child desc)
+	(manage-children trace sep descview)))))
+
+(defun display-structure-pane (s)
+  (with-inspector-pane (s)
+    (let* ((dd (info type defined-structure-info (structure-ref s 0)))
+	   (dsds (c::dd-slots dd))
+	   (viewer (when (> (length dsds) *inspector-huge-object-threshold*)
+		     (create-scrolled-window form "structureViewer"
+					     :left-attachment :attach-form
+					     :right-attachment :attach-form
+					     :top-attachment :attach-form
+					     :bottom-attachment :attach-form
+					     :scrolling-policy :automatic)))
+	   (rc (create-row-column (or viewer form) "rowColumn"))
+	   (widgets))
+      (declare (list dsds))
+      (dolist (dsd dsds)
+	(push
+	 (create-value-box rc (format nil "~A:"
+				      (string-capitalize (c::dsd-%name dsd)))
+			   (structure-ref s (c::dsd-index dsd))
+			   :callback #'inspect-object-callback)
+	 widgets))
+      (apply #'manage-children widgets)
+      (manage-child rc)
+      (when viewer (manage-child viewer)))))
+
+
+(defun sequence-redisplay-callback (widget call-data v s-text c-text view pane)
+  (declare (ignore widget call-data))
+  (handler-case
+      (let* ((start (read-from-string (car (get-values s-text :value))))
+	     (count (read-from-string (car (get-values c-text :value))))
+	     (length (length v))
+	     (widgets (reverse (xti:widget-children view)))
+	     (unused-ones)
+	     (used-ones))
+
+	(when (> (+ start count) length)
+	  (setf count (- length start))
+	  (set-values c-text :value (format nil "~a" count)))
+
+	(when (minusp start)
+	  (setf start 0)
+	  (set-values s-text :value (format nil "~a" 0)))
+
+	(dolist (widget widgets)
+	  (if (zerop count)
+	      (push widget unused-ones)
+	      (progn
+		(set-value-box widget (format nil "~a:" start) (elt v start)
+			       :callback #'inspect-object-callback)
+		(push widget used-ones)
+		(incf start)
+		(decf count))))
+
+	(dotimes (i count)
+	  (let ((pos (+ start i)))
+	    (push (create-value-box view (format nil "~a:" pos) (elt v pos)
+				    :callback #'inspect-object-callback)
+		  used-ones)))
+	(when unused-ones
+	    (apply #'unmanage-children unused-ones))
+	(apply #'manage-children used-ones))
+    (error (e)
+      (interface-error (format nil "~a" e) pane))))
+
+(defun sequence-filter-callback (widget call-data v fexp view pane)
+  (declare (ignore widget call-data))
+  (handler-case
+      (let* ((exp (read-from-string (car (get-values fexp :value))))
+	     (length (length v))
+	     (widgets (reverse (xti:widget-children view)))
+	     (used-ones))
+	(dotimes (index length)
+	  (let* ((item (elt v index))
+		 (* item)
+		 (** index))
+	    (when (eval exp)
+	      (let ((widget (pop widgets)))
+		(if widget
+		    (set-value-box widget (format nil "~a:" index) item
+				   :callback #'inspect-object-callback)
+		    (setf widget (create-value-box
+				  view (format nil "~a:" index) item
+				  :callback #'inspect-object-callback)))
+		(push widget used-ones)))))
+	(when widgets
+	  (apply #'unmanage-children widgets))
+	(apply #'manage-children used-ones))
+    (error (e)
+	   (interface-error (format nil "~a" e) pane))))
+
+(defmethod display-inspector-pane ((v sequence))
+  (with-inspector-pane (v)
+    (let* ((length (length v))
+	   (controls (create-row-column form "sequenceStartHolder"
+					:left-attachment :attach-form
+					:right-attachment :attach-form
+					:orientation :horizontal))
+	   (slabel (create-label-gadget controls "sequenceStartLabel"
+					:font-list *header-font*
+					:label-string "Start:"))
+	   (start (create-text controls "sequenceStart"
+			       :value "0"
+			       :columns 4))
+	   (clabel (create-label-gadget controls "sequenceCountLabel"
+					:font-list *header-font*
+					:label-string "Count:"))
+	   (count (create-text controls "sequenceCount"
+			       :value "5"
+			       :columns 4))
+	   (filter (create-row-column form "sequenceFilterHolder"
+				      :top-attachment :attach-widget
+				      :top-widget controls
+				      :left-attachment :attach-form
+				      :right-attachment :attach-form
+				      :orientation :horizontal))
+	   (flabel (create-label-gadget filter "sequenceFilterLabel"
+					:font-list *header-font*
+					:label-string "Filter:"))
+	   (fexp (create-text filter "sequenceFilterExp" :value "T"))
+	   (apply (create-push-button-gadget filter "sequenceFilterApply"
+					     :label-string "Apply"))
+	   (unapply (create-push-button-gadget filter "sequenceFilterUnapply"
+					       :label-string "No Filter"))
+	   (view (create-scrolled-window form "sequenceViewPort"
+					 :scrolling-policy :automatic
+					 :top-attachment :attach-widget
+					 :top-widget filter
+					 :bottom-attachment :attach-form
+					 :left-attachment :attach-form
+					 :right-attachment :attach-form))
+	   (rc (create-row-column view "sequenceView"
+				  :spacing 0))
+	   (widgets))
+
+      (manage-children slabel start clabel count)
+      (manage-children flabel fexp apply unapply)
+
+      (dotimes (i (min length *inspector-sequence-initial-display*))
+	(let ((item (elt v i)))
+	  (push (create-value-box rc (format nil "~a:" i) item
+				  :callback #'inspect-object-callback)
+		widgets)))
+
+      (apply #'manage-children widgets)
+
+      (add-callback start :activate-callback 'sequence-redisplay-callback
+		    v start count rc pane)
+      (add-callback count :activate-callback 'sequence-redisplay-callback
+		    v start count rc pane)
+      (add-callback apply :activate-callback 'sequence-filter-callback
+		    v fexp rc pane)
+      (add-callback fexp :activate-callback 'sequence-filter-callback
+		    v fexp rc pane)
+      (add-callback unapply :activate-callback
+		    #'(lambda (widget call-data)
+			(declare (ignore widget call-data))
+			(sequence-redisplay-callback
+			 nil nil v start count rc pane)))
+
+      (manage-children view controls filter)
+      (manage-child rc))))
+
+(defun show-slot-list (object slot-list view allocp label)
+  (let ((label (create-label-gadget view "slotLabel"
+				    :label-string label
+				    :font-list *header-font*))
+	(widgets))
+    (dolist (slotd slot-list)
+      (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
+		      slotd
+	(let* ((slot-label (if allocp
+			       (format nil "~a: " slot)
+			       (format nil "~a [~a]: " slot allocation)))
+	       (slot-bound (pcl:slot-boundp object slot))
+	       (slot-value (if slot-bound
+			       (pcl:slot-value object slot)
+			       "Unbound")))
+	  (push
+	   (create-value-box view slot-label slot-value
+			     :callback #'inspect-object-callback
+			     :activep slot-bound)
+	   widgets)))
+      (apply #'manage-children label widgets))))
+
+(defun display-clos-pane (object)
+  (with-inspector-pane (object)
+    (let* ((class (pcl:class-of object))
+	   (slotds (pcl::slots-to-inspect class object))
+	   (view (create-row-column form "rowColumn"
+				    :left-attachment :attach-form
+				    :right-attachment :attach-form
+				    :top-attachment :attach-form
+				    :bottom-attachment :attach-form))
+	   instance-slots class-slots other-slots)
+
+      (dolist (slotd slotds)
+	(pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
+			slotd
+	  (case allocation
+	    (:instance (push slotd instance-slots))
+	    (:class (push slotd class-slots))
+	    (otherwise (push slotd other-slots))))
+	(when instance-slots
+	  (show-slot-list object instance-slots view t
+			  "Slots with Instance allocation:"))
+	(when class-slots
+	  (show-slot-list object class-slots view t
+			  "Slots with Class allocation:"))
+	(when other-slots
+	  (show-slot-list object other-slots view nil
+			  "Slots with Other allocation:"))))))
+
+
+
+;;;; Functions for creating the Motif inspector
+
+(defun start-motif-inspector (object)
+  (verify-system-server-exists)
+  (multiple-value-bind (shell connection)
+		       (create-interface-shell)
+    (declare (ignore shell))
+    (with-motif-connection (connection)
+      (verify-control-pane-displayed)
+      (display-inspector-pane object)
+      (inspector-add-history-item object)))
+  object)
+
+
+
+;;;; User visible INSPECT function
+
+;;; INSPECT -- Public.
+;;;
+(defun inspect (object)
+  "This function allows the user to interactively examine Lisp objects.
+   INTERFACE indicates whether this should run with a :graphics interface
+   or a :command-line oriented one; when running without X, there is no
+   choice.  Supplying :window, :windows, :graphics, :graphical, and :x gets
+   a windowing interface, and supplying :command-line or :tty gets the
+   other style."
+
+  (if (use-graphics-interface)
+      (start-motif-inspector object)
+      (inspect::tty-inspect object)))
diff --git a/interface/interface.lisp b/interface/interface.lisp
new file mode 100644
index 000000000..1a0e56f15
--- /dev/null
+++ b/interface/interface.lisp
@@ -0,0 +1,721 @@
+;;;; -*- Mode: Lisp ; Package: Interface -*-
+;;;
+;;; This provides utilities used for building Lisp interface components
+;;; using the Motif toolkit.  Specifically, it is meant to be used by the
+;;; inspector and the debugger.
+
+(in-package "INTERFACE")
+
+
+
+;;;; Globally defined variables
+
+(defparameter entry-font-name "-adobe-helvetica-medium-r-normal--*-120-75-*")
+(defparameter header-font-name "-adobe-helvetica-bold-r-normal--*-120-75-*")
+(defparameter italic-font-name "-adobe-helvetica-medium-o-normal--*-120-75-*")
+
+
+(defvar *header-font*)
+(defvar *italic-font*)
+(defvar *entry-font*)
+(defvar *all-fonts*)
+
+(defvar *system-motif-server* nil)
+
+(defvar *lisp-interface-shell* nil)
+
+(defvar *lisp-interface-connection* nil)
+
+(defvar *lisp-interface-panes* nil)
+
+(defvar *lisp-interface-menus* nil)
+
+(defvar *busy-cursor*)
+
+
+;;; *INTERFACE-MODE* may be one of:
+;;;       :normal  -- normal interaction mode
+;;;       :edit    -- targetting object to edit
+;;;       :copy    -- targetting object to copy
+;;;       :paste   -- targetting object to copy into
+;;;
+(defvar *interface-mode* :normal)
+
+;;; This is where an object is stored when copied, and where paste looks to
+;;; find the value it needs to insert.
+;;;
+(defvar *copy-object* nil)
+
+(defvar *interface-style* :graphics
+  "This specifies the default interface mode for the debugger and inspector.
+   The allowable values are :GRAPHICS and :TTY.")
+
+
+
+;;;; Functions for dealing with interface widgets
+
+(defun create-interface-shell ()
+  (if *lisp-interface-shell*
+      (values *lisp-interface-shell* *lisp-interface-connection*)
+      (let ((con (xt::open-motif-connection
+		  *default-server-host* *default-display*
+		  "lisp" "Lisp"
+		  (and *system-motif-server*
+		       (ext:process-pid *system-motif-server*)))))
+	(with-motif-connection (con)
+	  (setf (xti:motif-connection-close-hook *motif-connection*)
+		#'close-connection-hook)
+	  (setf *header-font*
+		(build-simple-font-list "HeaderFont" header-font-name))
+	  (setf *italic-font*
+		(build-simple-font-list "ItalicFont" italic-font-name))
+	  (setf *entry-font*
+		(build-simple-font-list "EntryFont" entry-font-name))
+	  (setf *all-fonts*
+		(build-font-list `(("EntryFont" ,entry-font-name)
+				   ("HeaderFont" ,header-font-name)
+ 				   ("ItalicFont" ,italic-font-name))))
+
+	  (let ((shell (create-application-shell
+			:default-font-list *entry-font*)))
+	    (setf *lisp-interface-panes* (make-hash-table))
+	    (setf *lisp-interface-menus* (make-hash-table :test #'equal))
+	    (setf *lisp-interface-connection* con)
+	    (setf *lisp-interface-shell* shell)
+	    (setf *busy-cursor* (xt:create-font-cursor 150))
+	    (values shell con))))))
+
+(declaim (inline popup-interface-pane))
+(defun popup-interface-pane (pane)
+  (declare (type widget pane))
+  (popup pane :grab-none))
+
+(defun create-interface-pane-shell (title tag)
+  (declare (simple-string title))
+  (let* ((shell *lisp-interface-shell*)
+	 (existing (gethash tag *lisp-interface-panes*))
+	 (pane (or existing
+		   (create-popup-shell "interfacePaneShell"
+				       :top-level-shell shell
+				       :default-font-list *entry-font*
+				       :keyboard-focus-policy :pointer
+				       :title title
+				       :icon-name title))))
+    (setf (gethash tag *lisp-interface-panes*) pane)
+    (values pane (not existing))))
+
+(defun find-interface-pane (tag)
+  (if *lisp-interface-panes*
+      (gethash tag *lisp-interface-panes*)))
+
+(defun destroy-interface-pane (tag)
+  (let ((pane (and *lisp-interface-panes*
+		   (gethash tag *lisp-interface-panes*))))
+    (when pane
+      (destroy-widget pane)
+      (remhash tag *lisp-interface-panes*))))
+
+
+
+;;;; Functions for dealing with menus
+
+;; `(("New" ,#'new-thing-callback this that)
+;;   ("Load" ,#'load-thing-callback loadee))
+
+(defun create-interface-menu (menu-bar name menu-spec)
+  (declare (simple-string name))
+  (let* ((pulldown (create-pulldown-menu menu-bar "pulldown"))
+	 (cascade (create-cascade-button menu-bar "cascade"
+					 :sub-menu-id pulldown
+					 :label-string name))
+	 (widgets))
+
+    (dolist (entry menu-spec)
+      (if (and entry (listp entry))
+	  (let ((widget (create-push-button-gadget pulldown "menuEntry"
+						   :label-string (car entry))))
+	    (when (cdr entry)
+	      (apply #'add-callback widget :activate-callback (cdr entry)))
+	    (push widget widgets))
+	  (let ((widget (create-separator-gadget pulldown "menuSeparator")))
+	    (push widget widgets))))
+    (apply #'manage-children widgets)
+    cascade))
+
+(defun create-cached-menu (menu-bar name &optional menu-spec)
+  (if menu-spec
+      (setf (gethash name *lisp-interface-menus*) menu-spec)
+      (setf menu-spec (gethash name *lisp-interface-menus*)))
+  (create-interface-menu menu-bar name menu-spec))
+
+(defun create-highlight-button (parent name label)
+  (create-push-button-gadget parent name
+			     :label-string label
+			     :highlight-on-enter t
+			     :shadow-thickness 0))
+
+
+
+;;;; Functions for making/changing value boxes
+
+(defparameter *string-cutoff* 60)
+
+(defun trim-string (string)
+  (declare (simple-string string))
+  (if (> (length string) *string-cutoff*)
+      (let ((new (make-string (+ 4 *string-cutoff*))))
+        (replace new string :end2 *string-cutoff*)
+        (replace new " ..." :start1 *string-cutoff*))
+      string))
+
+(defun print-for-widget-display (string arg)
+  (let ((*print-pretty* nil)
+	(*print-length* 20)
+	(*print-level* 2))
+    (trim-string (format nil string arg))))
+
+(defun create-value-box (parent name value
+			 &key callback client-data (activep t))
+  (let* ((rc (create-row-column parent "valueBox"
+				:margin-height 0
+				:margin-width 0
+				:orientation :horizontal))
+	 (label (create-label-gadget rc "valueLabel"
+				     :font-list *header-font*
+				     :label-string name))
+	 (button (if activep
+		     (create-highlight-button rc "valueObject"
+					      (print-for-widget-display
+					       "~S" value))
+		     (create-label-gadget rc "valueObject"
+					  :font-list *italic-font*
+					  :label-string
+					  (format nil "~A" value)))))
+    (manage-children label button)
+    (when (and callback activep)
+      (add-callback button :activate-callback
+		    callback (or client-data value)))
+    rc))
+
+(defmacro with-widget-children ((this-child widget) &rest clauses)
+  `(let ((children (xti:widget-children ,widget)))
+     (dolist (,this-child children)
+       ,(cons 'case
+	      (cons `(xti:widget-type ,this-child) clauses)))))
+
+(defun set-value-box (vbox name value &key callback client-data)
+  (with-widget-children (child vbox)
+    (:push-button-gadget
+     (set-values child :label-string
+		 (print-for-widget-display "~S" value))
+     (remove-all-callbacks child :activate-callback)
+     (when callback
+       (add-callback child :activate-callback callback (or client-data value))))
+    (:label-gadget
+     (set-values child :label-string name))))
+
+
+
+;;;; Misc. stuff
+
+(defun nuke-interface ()
+  (with-motif-connection (*lisp-interface-connection*)
+    (quit-application)))
+
+(defun interface-error (text &optional (pane *lisp-interface-shell*))
+  (declare (simple-string text))
+  (multiple-value-bind
+      (dialog shell)
+      (create-error-dialog pane "lispInterfaceError" :message-string text)
+    (set-values shell :title "Error")
+    (manage-child dialog)))
+
+(defmacro with-busy-cursor ((pane) &body forms)
+  `(let ((window (widget-window ,pane)))
+     (unwind-protect
+	 (progn
+	   (with-clx-requests (setf (xlib:window-cursor window) *busy-cursor*))
+	   ,@forms)
+       (setf (xlib:window-cursor window) :none))))
+
+(defmacro grab-output-as-string (&body forms)
+  `(let* ((stream (make-string-output-stream))
+	  (*standard-output* stream)
+	  (value (progn ,@forms)))
+     (close stream)
+     (values (get-output-stream-string stream) value)))
+
+(defun ask-for-confirmation (pane message callback)
+  (declare (simple-string message))
+  (multiple-value-bind
+      (dialog shell)
+      (create-question-dialog pane "lispConfirmation" :message-string message)
+    (set-values shell :title "Are You Sure?")
+    (add-callback dialog :ok-callback callback)
+    (manage-child dialog)))
+
+(defun use-graphics-interface (&optional (kind *interface-style*))
+  (cond
+   ((and (member kind '(:window :windows :graphics :graphical :x))
+	 (assoc :display ext:*environment-list*))
+    t)
+   ((member kind '(:command-line :tty)) nil)
+   (t
+    (error "Interface specification must be one of :window, :windows, ~%~
+	    :graphics, :graphical, :x, :command-line, or :tty -- ~%~
+	    not ~S." kind))))
+
+(defun close-connection-hook (connection)
+  (declare (ignore connection))
+  (setf *lisp-interface-panes* nil)
+  (setf *lisp-interface-menus* nil)
+  (setf *lisp-interface-connection* nil)
+  (setf *lisp-interface-shell* nil))
+
+(defun system-server-status-hook (process)
+  (let ((status (ext:process-status process)))
+    (when (or (eq status :exited)
+	      (eq status :signaled))
+      (setf *system-motif-server* nil))))
+
+(defun verify-system-server-exists ()
+  (when (and (not xt:*default-server-host*)
+	     (or (not *system-motif-server*)
+		 (and *system-motif-server*
+		      (not (ext:process-alive-p *system-motif-server*)))))
+    (let ((process (ext:run-program (merge-pathnames *clm-binary-name*
+						     *clm-binary-directory*)
+				    '("-nofork" "-local")
+				    :wait nil
+				    :status-hook #'system-server-status-hook)))
+      (unless (and process (ext:process-alive-p process))
+	(xti:toolkit-error "Could not start Motif server process."))
+      ;;
+      ;; Wait until the server has started up
+      (loop
+	(when (probe-file (format nil "/tmp/.motif_socket-p~a"
+				  (ext:process-pid process)))
+	  (return))
+	(sleep 2))
+      (setf *system-motif-server* process))))
+
+
+
+;;;; Handling of the Inspector items in the Control Panel
+
+(defconstant *history-size* 25)
+
+(defvar *inspector-history*)
+
+(defstruct (inspector-history
+	    (:print-function print-inspector-history)
+	    (:conc-name history-)
+	    (:constructor make-inspector-history (widget)))
+  (record (make-array *history-size*) :type simple-vector)
+  (head 0 :type fixnum)
+  (tail 0 :type fixnum)
+  (widget nil :type (or nil widget)))
+
+(defun print-inspector-history (hist stream d)
+  (declare (ignore hist d))
+  (write-string "#<Inspector History>" stream))
+
+(defun inspector-add-history-item (object)
+  (let* ((h *inspector-history*)
+	 (tail (history-tail h))
+	 (head (history-head h))
+	 (widget (history-widget h)))
+    ;;
+    ;; Only add new items to the history if they're not there already
+    (unless (position object (history-record h))
+      (setf (svref (history-record h) tail) object)
+      (setf tail (mod (1+ tail) *history-size*))
+      (setf (history-tail h) tail)
+      ;;
+      ;; Add new item at the top of the history list
+      (list-add-item widget (print-for-widget-display "~S" object) 1)
+      (when (= tail head)
+	(setf (history-head h) (mod (1+ head) *history-size*))
+	;;
+	;; Nuke old item at bottom of history
+	(list-delete-pos widget 0)))))
+
+(defun eval-and-inspect-callback (widget call-data pane)
+  (declare (ignore call-data))
+  (let ((input (car (get-values widget :value))))
+    (handler-case
+	(let ((object (eval (read-from-string input))))
+	  (with-busy-cursor (pane)
+	    (text-set-string widget "")
+	    (display-inspector-pane object)
+	    (inspector-add-history-item object)))
+      (error (e)
+        (interface-error (format nil "~a" e) (xti:widget-user-data widget))))))
+
+(defun inspector-history-callback (widget call-data pane)
+  (let* ((pos (list-callback-item-position call-data))
+	 (object (svref (history-record *inspector-history*)
+			(mod (- (history-tail *inspector-history*) pos)
+			     *history-size*))))
+    (with-busy-cursor (pane)
+      (update-display widget)
+      (display-inspector-pane object)
+      (list-deselect-pos widget pos))))
+
+
+
+;;;; The CLOS generic functions for the inspector
+
+(defgeneric inspector-pane-title (object)
+  (:documentation
+   "Returns a string which is meant to be the title of the inspection pane
+    displaying the given object."))
+
+(defgeneric display-inspector-pane (object)
+  (:documentation
+   "Creates a window pane which displays relevant information about the
+    given object."))
+
+
+
+;;;; Build the Lisp Control Panel
+
+(defconstant *control-cookie* (cons :lisp :control))
+
+(defvar *file-selection-hook* #'load)
+
+(defvar *file-list* nil)
+
+(defun file-selection-callback (widget call-data)
+  (declare (ignore widget))
+  (let ((string (compound-string-get-ltor
+		 (file-selection-callback-value call-data) "")))
+    (with-callback-deferred-actions
+      (funcall *file-selection-hook* string))))
+
+(defun add-file-callback (widget call-data fsel files)
+  (declare (ignore widget call-data))
+  (setf *file-selection-hook*
+	#'(lambda (fname)
+	    (let* ((base-name (pathname-name fname))
+		   (path (directory-namestring fname))
+		   (name (format nil "~a~a" path base-name))
+		   (xs (compound-string-create
+		       (format nil "~a  ~a" base-name path) "")))
+	      (list-add-item files xs 1)
+	      (push (cons name xs) *file-list*))))
+  (manage-child fsel))
+
+
+(defun remove-files-callback (widget call-data files)
+  (declare (ignore widget call-data))
+  (let ((selections (list-get-selected-pos files))
+	(items))
+    (dolist (pos selections)
+      (let ((item (elt *file-list* (1- pos))))
+	(list-delete-item files (cdr item))
+	(push item items)))
+
+    (dolist (item items)
+      (setf *file-list* (delete item *file-list*)))))
+
+(defun load-files-callback (widget call-data files)
+  (declare (ignore widget call-data))
+  (let ((selections (list-get-selected-pos files)))
+    (with-callback-deferred-actions
+      (dolist (pos selections)
+	(load (car (elt *file-list* (1- pos))))))))
+
+(defun compile-files-callback (widget call-data files)
+  (declare (ignore widget call-data))
+  (let ((selections (list-get-selected-pos files)))
+    (with-callback-deferred-actions
+      (with-compilation-unit ()
+	(dolist (pos selections)
+	  (compile-file (car (elt *file-list* (1- pos)))))))))
+
+(defun apropos-callback (widget call-data pane)
+  (declare (ignore call-data))
+  (with-busy-cursor (pane)
+    (let* ((input (car (get-values widget :value)))
+	   (results (apropos-list input)))
+      (text-set-string widget "")
+      (multiple-value-bind (form shell)
+			   (create-form-dialog pane "aproposDialog")
+	(let* ((done (create-push-button-gadget form "aproposDone"
+						:left-attachment :attach-form
+						:right-attachment :attach-form
+						:label-string "Done"))
+	       (list (create-scrolled-list form "aproposList"
+					   :visible-item-count 10
+					   :left-attachment :attach-form
+					   :right-attachment :attach-form
+					   :bottom-attachment :attach-form
+					   :top-attachment :attach-widget
+					   :top-widget done)))
+	  (set-values shell :title "Apropos Results"
+	                    :keyboard-focus-policy :pointer)
+	  (dolist (sym results)
+	    (list-add-item list (symbol-name sym) 0))
+	  (add-callback done :activate-callback #'destroy-callback shell)
+	  (add-callback list :browse-selection-callback
+			#'(lambda (w c) (declare (ignore w))
+			    (with-busy-cursor (shell)
+			      (let ((pos (list-callback-item-position c)))
+				(inspect (elt results (1- pos)))))))
+	  (manage-child done)
+	  (manage-child list)
+	  (manage-child form))))))
+
+(defun about-callback (widget call-data pane)
+  (declare (ignore widget call-data))
+  (multiple-value-bind
+      (msg shell)
+      (create-message-dialog pane "aboutDialog"
+			     :dialog-title "About Lisp"
+			     :message-string (grab-output-as-string
+					    (print-herald)))
+    (declare (ignore shell))
+    (let ((help (message-box-get-child msg :dialog-help-button))
+	  (cancel (message-box-get-child msg :dialog-cancel-button)))
+      (destroy-widget help)
+      (destroy-widget cancel)
+      (manage-child msg))))
+
+(defun set-compile-policy-callback (widget call-data speed space safety
+					   debug cspeed brevity)
+  (declare (ignore widget call-data))
+  (flet ((get-policy-value (widget)
+	   (coerce (/ (car (get-values widget :value)) 10) 'single-float)))
+    (let ((speed-val (get-policy-value speed))
+	  (space-val (get-policy-value space))
+	  (safety-val (get-policy-value safety))
+	  (debug-val (get-policy-value debug))
+	  (cspd-val (get-policy-value cspeed))
+	  (brev-val (get-policy-value brevity)))
+
+      (proclaim (list 'optimize
+		      (list 'speed speed-val)
+		      (list 'space space-val)
+		      (list 'safety safety-val)
+		      (list 'debug debug-val)
+		      (list 'compilation-speed cspd-val)
+		      (list 'ext:inhibit-warnings brev-val))))))
+
+(defun compile-policy-callback (widget call-data pane)
+  (declare (ignore widget call-data))
+  (multiple-value-bind (form shell)
+		       (create-form-dialog pane "compilationDialog")
+    (flet ((create-policy (parent title value)
+	     (create-scale parent "policy"
+			   :decimal-points 1
+			   :orientation :horizontal
+			   :maximum 30
+			   :show-value t
+			   :title-string title
+			   :value (truncate (* 10 value)))))
+      (let* ((cookie c::*default-cookie*)
+	     (rc (create-row-column form "policies"
+				    :packing :pack-column
+				    :num-columns 2))
+	     (speed (create-policy rc "Speed" (c::cookie-speed cookie)))
+	     (space (create-policy rc "Space" (c::cookie-space cookie)))
+	     (safety (create-policy rc "Safety" (c::cookie-safety cookie)))
+	     (debug (create-policy rc "Debug" (c::cookie-debug cookie)))
+	     (cspeed (create-policy rc "Compilation Speed"
+				    (c::cookie-cspeed cookie)))
+	     (brevity (create-policy rc "Inhibit Warnings"
+				     (c::cookie-brevity cookie)))
+	     (sep (create-separator-gadget form "separator"
+					   :top-attachment :attach-widget
+					   :top-widget rc
+					   :left-attachment :attach-form
+					   :right-attachment :attach-form))
+	     (done (create-push-button-gadget form "done"
+					    :label-string "Done"
+					    :top-attachment :attach-widget
+					    :top-widget sep
+					    :left-attachment :attach-position
+					    :right-attachment :attach-position
+					    :left-position 35
+					    :right-position 65)))
+	(set-values shell :title "Compilation Options"
+		    :keyboard-focus-policy :pointer)
+	(add-callback done :activate-callback
+		      'set-compile-policy-callback
+		      speed space safety debug cspeed brevity)
+	(manage-children speed space safety debug cspeed brevity)
+	(manage-children sep done rc)
+	(manage-child form)))))
+
+(defun display-control-pane ()
+  (let* ((pane (create-interface-pane-shell (lisp-implementation-type)
+					    *control-cookie*))
+	 (form (create-form pane "form"))
+	 (fsel (create-file-selection-dialog pane "lispFileSelector"
+					     :auto-unmanage t))
+	 (menu-bar (create-menu-bar form "lispMenu"
+				    :left-attachment :attach-form
+				    :right-attachment :attach-form))
+	 (lmenu (create-interface-menu
+		 menu-bar "Lisp"
+		 `(("About ..." about-callback ,pane)
+		   "-----"
+		   ("Load File" ,#'(lambda (w c)
+				     (declare (ignore w c))
+				     (setf *file-selection-hook* #'load)
+				     (manage-child fsel)))
+		   ("Compile File" ,#'(lambda (w c) (declare (ignore w c))
+					(setf *file-selection-hook*
+					      #'compile-file)
+					(manage-child fsel)))
+		   "-----"
+		   ("Close Control Panel" ,#'popdown-callback ,pane)
+		   ("Quit Lisp" ,#'(lambda (w c pane)
+				     (declare (ignore w c))
+				     (ask-for-confirmation
+				      pane "Do you really want to quit?"
+				      #'(lambda (w c) (declare (ignore w c))
+					  (xt::quit-server)
+					  (quit))))
+		    ,pane))))
+	 (fmenu (create-interface-menu
+		 menu-bar "Files"
+		 `(("Load File Group")
+		   ("Save File Group"))))
+	 (omenu (create-interface-menu
+		 menu-bar "Options"
+		 `(("Compilation policy ..." compile-policy-callback ,pane))))
+	 (vsep (create-separator form "separator"
+				 :orientation :vertical
+				 :top-attachment :attach-widget
+				 :top-widget menu-bar
+				 :bottom-attachment :attach-form
+				 :right-attachment :attach-position
+				 :right-position 50))
+	 (prompt (create-label-gadget form "inspectPrompt"
+				      :top-attachment :attach-widget
+				      :top-widget menu-bar
+				      :font-list *header-font*
+				      :label-string "Inspect new object:"))
+	 (entry (create-text form "inspectEval"
+			     :top-attachment :attach-widget
+			     :top-widget prompt
+			     :left-offset 4
+			     :right-offset 4
+			     :left-attachment :attach-form
+			     :right-attachment :attach-widget
+			     :right-widget vsep))
+	 (hlabel (create-label-gadget form "inspectHistoryLabel"
+				      :top-attachment :attach-widget
+				      :top-widget entry
+				      :font-list *header-font*
+				      :label-string "Inspector History:"))
+	 (hview (create-scrolled-list form "inspectHistory"
+				      :visible-item-count 5
+				      :left-offset 4
+				      :right-offset 4
+				      :bottom-offset 4
+				      :top-attachment :attach-widget
+				      :top-widget hlabel
+				      :left-attachment :attach-form
+				      :right-attachment :attach-widget
+				      :right-widget vsep
+				      :bottom-attachment :attach-form))
+	 (flabel (create-label-gadget form "filesLabel"
+				      :left-attachment :attach-widget
+				      :left-widget vsep
+				      :top-attachment :attach-widget
+				      :top-widget menu-bar
+				      :label-string "Files:"
+				      :font-list *header-font*))
+	 (frc (create-row-column form "filesButtons" 
+				 :packing :pack-column
+				 :num-columns 2
+				 :left-attachment :attach-widget
+				 :left-widget vsep
+				 :top-attachment :attach-widget
+				 :top-widget flabel
+				 :right-attachment :attach-form
+				 :right-offset 4))
+	 (add (create-push-button-gadget frc "fileAdd"
+					 :label-string "Add File"))
+	 (remove (create-push-button-gadget frc "fileRemove"
+					    :label-string "Remove Files"))
+	 (load (create-push-button-gadget frc "fileLoad"
+					  :label-string "Load Files"))
+	 (compile (create-push-button-gadget frc "fileCompile"
+					     :label-string "Compile Files"))
+	 (apropos (create-text form "apropos"
+			       :left-attachment :attach-widget
+			       :left-widget vsep
+			       :right-attachment :attach-form
+			       :bottom-attachment :attach-form
+			       :left-offset 4
+			       :right-offset 4
+			       :bottom-offset 4))
+	 (alabel (create-label-gadget form "aproposLabel"
+				      :label-string "Apropos:"
+				      :font-list *header-font*
+				      :left-attachment :attach-widget
+				      :left-widget vsep
+				      :bottom-attachment :attach-widget
+				      :bottom-widget apropos))
+	 (hsep (create-separator-gadget form "separator"
+					:left-attachment :attach-widget
+					:left-widget vsep
+					:right-attachment :attach-form
+					:bottom-attachment :attach-widget
+					:bottom-widget alabel))
+	 (files (create-scrolled-list form "files"
+				      :visible-item-count 5
+				      :selection-policy :multiple-select
+				      :top-attachment :attach-widget
+				      :top-widget frc
+				      :left-attachment :attach-widget
+				      :left-widget vsep
+				      :left-offset 4
+				      :right-attachment :attach-form
+				      :right-offset 4
+				      :bottom-attachment :attach-widget
+				      :bottom-widget hsep
+				      :bottom-offset 4)))
+				      
+    (manage-child form)
+    (manage-children lmenu fmenu omenu)
+    (manage-child files)
+    (manage-children menu-bar vsep prompt entry hlabel flabel frc
+		     apropos alabel hsep)
+    (manage-children add remove load compile)
+    (manage-child hview)
+    (set-values fmenu :sensitive nil)
+
+    (setf *inspector-history* (make-inspector-history hview))
+    (setf (xti:widget-user-data entry) pane)
+
+    (add-callback entry :activate-callback #'eval-and-inspect-callback pane)
+    (add-callback hview :browse-selection-callback
+		  #'inspector-history-callback pane)
+    (add-callback fsel :ok-callback 'file-selection-callback)
+    (add-callback add :activate-callback 'add-file-callback fsel files)
+    (add-callback remove :activate-callback 'remove-files-callback files)
+    (add-callback load :activate-callback 'load-files-callback files)
+    (add-callback compile :activate-callback 'compile-files-callback files)
+    (add-callback apropos :activate-callback 'apropos-callback pane)
+    (popup-interface-pane pane)
+    pane))
+
+(defun verify-control-pane-displayed ()
+  (let ((pane (find-interface-pane *control-cookie*)))
+    (unless pane
+      (setf pane (display-control-pane)))
+    (unless (is-managed pane)
+      (popup-interface-pane pane))))
+
+(defun lisp-control-panel ()
+  (verify-system-server-exists)
+  (multiple-value-bind (shell connection)
+		       (create-interface-shell)
+    (declare (ignore shell))
+    (with-motif-connection (connection)
+      (verify-control-pane-displayed))))
-- 
GitLab