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