Skip to content
Snippets Groups Projects
Commit 7a90c402 authored by garland's avatar garland
Browse files

Initial revision

parent 819f608f
No related branches found
No related tags found
No related merge requests found
;;;; -*- 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)))
|#
;;;; -*- 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"))
;;;; -*- 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)))
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment