/[cmucl]/src/interface/interface.lisp
ViewVC logotype

Contents of /src/interface/interface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Feb 22 12:26:40 1993 UTC (21 years, 1 month ago) by garland
Branch: MAIN
Changes since 1.3: +42 -6 lines
Invoking LISP-CONTROL-PANEL from the TTY now works correctly and
QUIT will kill off any Motif servers that you have started.
1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Michael Garland
12 ;;;
13 ;;; This provides utilities used for building Lisp interface components
14 ;;; using the Motif toolkit. Specifically, it is meant to be used by the
15 ;;; inspector and the debugger.
16 ;;;
17
18 (in-package "INTERFACE")
19
20
21
22 ;;;; Globally defined variables
23
24 (defparameter entry-font-name "-adobe-helvetica-medium-r-normal--*-120-75-*")
25 (defparameter header-font-name "-adobe-helvetica-bold-r-normal--*-120-75-*")
26 (defparameter italic-font-name "-adobe-helvetica-medium-o-normal--*-120-75-*")
27
28
29 (defvar *header-font*)
30 (defvar *italic-font*)
31 (defvar *entry-font*)
32 (defvar *all-fonts*)
33
34 (defvar *system-motif-server* nil)
35
36 (defvar *lisp-interface-shell* nil)
37
38 (defvar *lisp-interface-connection* nil)
39
40 (defvar *lisp-interface-panes* nil)
41
42 (defvar *lisp-interface-menus* nil)
43
44 (defvar *busy-cursor*)
45
46
47 ;;; *INTERFACE-MODE* may be one of:
48 ;;; :normal -- normal interaction mode
49 ;;; :edit -- targetting object to edit
50 ;;; :copy -- targetting object to copy
51 ;;; :paste -- targetting object to copy into
52 ;;;
53 (defvar *interface-mode* :normal)
54
55 ;;; This is where an object is stored when copied, and where paste looks to
56 ;;; find the value it needs to insert.
57 ;;;
58 (defvar *copy-object* nil)
59
60 (defvar *interface-style* :graphics
61 "This specifies the default interface mode for the debugger and inspector.
62 The allowable values are :GRAPHICS and :TTY.")
63
64
65
66 ;;;; Functions for dealing with interface widgets
67
68 (defun create-interface-shell ()
69 (if *lisp-interface-shell*
70 (values *lisp-interface-shell* *lisp-interface-connection*)
71 (let ((con (xt::open-motif-connection
72 *default-server-host* *default-display*
73 "lisp" "Lisp"
74 (and *system-motif-server*
75 (ext:process-pid *system-motif-server*)))))
76 (with-motif-connection (con)
77 (setf (xti:motif-connection-close-hook *motif-connection*)
78 #'close-connection-hook)
79 (setf *header-font*
80 (build-simple-font-list "HeaderFont" header-font-name))
81 (setf *italic-font*
82 (build-simple-font-list "ItalicFont" italic-font-name))
83 (setf *entry-font*
84 (build-simple-font-list "EntryFont" entry-font-name))
85 (setf *all-fonts*
86 (build-font-list `(("EntryFont" ,entry-font-name)
87 ("HeaderFont" ,header-font-name)
88 ("ItalicFont" ,italic-font-name))))
89
90 (let ((shell (create-application-shell
91 :default-font-list *entry-font*)))
92 (setf *lisp-interface-panes* (make-hash-table))
93 (setf *lisp-interface-menus* (make-hash-table :test #'equal))
94 (setf *lisp-interface-connection* con)
95 (setf *lisp-interface-shell* shell)
96 (setf *busy-cursor* (xt:create-font-cursor 150))
97 (values shell con))))))
98
99 (declaim (inline popup-interface-pane))
100 (defun popup-interface-pane (pane)
101 (declare (type widget pane))
102 (popup pane :grab-none))
103
104 (defun create-interface-pane-shell (title tag)
105 (declare (simple-string title))
106 (let* ((shell *lisp-interface-shell*)
107 (existing (gethash tag *lisp-interface-panes*))
108 (pane (or existing
109 (create-popup-shell "interfacePaneShell"
110 :top-level-shell shell
111 :default-font-list *entry-font*
112 :keyboard-focus-policy :pointer
113 :title title
114 :icon-name title))))
115 (setf (gethash tag *lisp-interface-panes*) pane)
116 (values pane (not existing))))
117
118 (defun find-interface-pane (tag)
119 (if *lisp-interface-panes*
120 (gethash tag *lisp-interface-panes*)))
121
122 (defun destroy-interface-pane (tag)
123 (let ((pane (and *lisp-interface-panes*
124 (gethash tag *lisp-interface-panes*))))
125 (when pane
126 (destroy-widget pane)
127 (remhash tag *lisp-interface-panes*))))
128
129
130
131 ;;;; Functions for dealing with menus
132
133 ;; `(("New" ,#'new-thing-callback this that)
134 ;; ("Load" ,#'load-thing-callback loadee))
135
136 (defun create-interface-menu (menu-bar name menu-spec)
137 (declare (simple-string name))
138 (let* ((pulldown (create-pulldown-menu menu-bar "pulldown"))
139 (cascade (create-cascade-button menu-bar "cascade"
140 :sub-menu-id pulldown
141 :label-string name))
142 (widgets))
143
144 (dolist (entry menu-spec)
145 (if (and entry (listp entry))
146 (let ((widget (create-push-button pulldown "menuEntry"
147 :label-string (car entry))))
148 (when (cdr entry)
149 (apply #'add-callback widget :activate-callback (cdr entry)))
150 (push widget widgets))
151 (let ((widget (create-separator pulldown "menuSeparator")))
152 (push widget widgets))))
153 (apply #'manage-children widgets)
154 cascade))
155
156 (defun create-cached-menu (menu-bar name &optional menu-spec)
157 (if menu-spec
158 (setf (gethash name *lisp-interface-menus*) menu-spec)
159 (setf menu-spec (gethash name *lisp-interface-menus*)))
160 (create-interface-menu menu-bar name menu-spec))
161
162 (defun create-highlight-button (parent name label)
163 (create-push-button parent name
164 :label-string label
165 :highlight-on-enter t
166 :shadow-thickness 0))
167
168
169
170 ;;;; Functions for making/changing value boxes
171
172 (defparameter *string-cutoff* 60)
173
174 (defun trim-string (string)
175 (declare (simple-string string))
176 (if (> (length string) *string-cutoff*)
177 (let ((new (make-string (+ 4 *string-cutoff*))))
178 (replace new string :end2 *string-cutoff*)
179 (replace new " ..." :start1 *string-cutoff*))
180 string))
181
182 (defun print-for-widget-display (string arg)
183 (let ((*print-pretty* nil)
184 (*print-length* 20)
185 (*print-level* 2))
186 (trim-string (format nil string arg))))
187
188 (defun create-value-box (parent name value
189 &key callback client-data (activep t))
190 (let* ((rc (create-row-column parent "valueBox"
191 :margin-height 0
192 :margin-width 0
193 :orientation :horizontal))
194 (label (create-label rc "valueLabel"
195 :font-list *header-font*
196 :label-string name))
197 (button (if activep
198 (create-highlight-button rc "valueObject"
199 (print-for-widget-display
200 "~S" value))
201 (create-label rc "valueObject"
202 :font-list *italic-font*
203 :label-string
204 (format nil "~A" value)))))
205 (manage-children label button)
206 (when (and callback activep)
207 (add-callback button :activate-callback
208 callback (or client-data value)))
209 rc))
210
211 (defmacro with-widget-children ((this-child widget) &rest clauses)
212 `(let ((children (xti:widget-children ,widget)))
213 (dolist (,this-child children)
214 ,(cons 'case
215 (cons `(xti:widget-type ,this-child) clauses)))))
216
217 (defun set-value-box (vbox name value &key callback client-data)
218 (with-widget-children (child vbox)
219 (:push-button
220 (set-values child :label-string
221 (print-for-widget-display "~S" value))
222 (remove-all-callbacks child :activate-callback)
223 (when callback
224 (add-callback child :activate-callback callback (or client-data value))))
225 (:label
226 (set-values child :label-string name))))
227
228
229
230 ;;;; Misc. stuff
231
232 (defun nuke-interface ()
233 (with-motif-connection (*lisp-interface-connection*)
234 (quit-application)))
235
236 (defun interface-error (text &optional (pane *lisp-interface-shell*))
237 (declare (simple-string text))
238 (multiple-value-bind
239 (dialog shell)
240 (create-error-dialog pane "lispInterfaceError" :message-string text)
241 (set-values shell :title "Error")
242 (manage-child dialog)))
243
244 (defmacro with-busy-cursor ((pane) &body forms)
245 `(let ((window (widget-window ,pane)))
246 (unwind-protect
247 (progn
248 (with-clx-requests (setf (xlib:window-cursor window) *busy-cursor*))
249 ,@forms)
250 (setf (xlib:window-cursor window) :none))))
251
252 (defmacro grab-output-as-string (&body forms)
253 `(let* ((stream (make-string-output-stream))
254 (*standard-output* stream)
255 (value (progn ,@forms)))
256 (close stream)
257 (values (get-output-stream-string stream) value)))
258
259 (defun ask-for-confirmation (pane message callback)
260 (declare (simple-string message))
261 (multiple-value-bind
262 (dialog shell)
263 (create-question-dialog pane "lispConfirmation" :message-string message)
264 (set-values shell :title "Are You Sure?")
265 (add-callback dialog :ok-callback callback)
266 (manage-child dialog)))
267
268 (defun use-graphics-interface (&optional (kind *interface-style*))
269 (cond
270 ((not (assoc :display ext:*environment-list*)) nil)
271 ((member kind '(:window :windows :graphics :graphical :x)) t)
272 ((member kind '(:command-line :tty)) nil)
273 (t
274 (let ((*interface-style* :tty))
275 (error "Interface specification must be one of :window, :windows, ~%~
276 :graphics, :graphical, :x, :command-line, or :tty -- ~%~
277 not ~S." kind)))))
278
279 (defun close-connection-hook (connection)
280 (declare (ignore connection))
281 (setf *lisp-interface-panes* nil)
282 (setf *lisp-interface-menus* nil)
283 (setf *lisp-interface-connection* nil)
284 (setf *lisp-interface-shell* nil))
285
286 (defun system-server-status-hook (process)
287 (let ((status (ext:process-status process)))
288 (when (or (eq status :exited)
289 (eq status :signaled))
290 (setf *system-motif-server* nil))))
291
292 (defun verify-system-server-exists ()
293 (when (and (not xt:*default-server-host*)
294 (or (not *system-motif-server*)
295 (and *system-motif-server*
296 (not (ext:process-alive-p *system-motif-server*)))))
297 (let ((process (ext:run-program (merge-pathnames *clm-binary-name*
298 *clm-binary-directory*)
299 '("-nofork" "-local")
300 :wait nil
301 :status-hook #'system-server-status-hook)))
302 (unless (and process (ext:process-alive-p process))
303 (xti:toolkit-error "Could not start Motif server process."))
304 ;;
305 ;; Wait until the server has started up
306 (loop
307 (when (probe-file (format nil "/tmp/.motif_socket-p~a"
308 (ext:process-pid process)))
309 (return))
310 (sleep 2))
311 (setf *system-motif-server* process))))
312
313
314
315 ;;;; Handling of the Inspector items in the Control Panel
316
317 (defconstant *history-size* 25)
318
319 (defvar *inspector-history*)
320
321 (defstruct (inspector-history
322 (:print-function print-inspector-history)
323 (:conc-name history-)
324 (:constructor make-inspector-history (widget)))
325 (record (make-array *history-size*) :type simple-vector)
326 (head 0 :type fixnum)
327 (tail 0 :type fixnum)
328 (widget nil :type (or nil widget)))
329
330 (defun print-inspector-history (hist stream d)
331 (declare (ignore hist d))
332 (write-string "#<Inspector History>" stream))
333
334 (defun inspector-add-history-item (object)
335 (let* ((h *inspector-history*)
336 (tail (history-tail h))
337 (head (history-head h))
338 (widget (history-widget h)))
339 ;;
340 ;; Only add new items to the history if they're not there already
341 (unless (position object (history-record h))
342 (setf (svref (history-record h) tail) object)
343 (setf tail (mod (1+ tail) *history-size*))
344 (setf (history-tail h) tail)
345 ;;
346 ;; Add new item at the top of the history list
347 (list-add-item widget (print-for-widget-display "~S" object) 1)
348 (when (= tail head)
349 (setf (history-head h) (mod (1+ head) *history-size*))
350 ;;
351 ;; Nuke old item at bottom of history
352 (list-delete-pos widget 0)))))
353
354 (defun eval-and-inspect-callback (widget call-data pane)
355 (declare (ignore call-data))
356 (let ((input (car (get-values widget :value))))
357 (handler-case
358 (let ((object (eval (read-from-string input))))
359 (with-busy-cursor (pane)
360 (text-set-string widget "")
361 (display-inspector-pane object)
362 (inspector-add-history-item object)))
363 (error (e)
364 (interface-error (format nil "~a" e) (xti:widget-user-data widget))))))
365
366 (defun inspector-history-callback (widget call-data pane)
367 (let* ((pos (list-callback-item-position call-data))
368 (object (svref (history-record *inspector-history*)
369 (mod (- (history-tail *inspector-history*) pos)
370 *history-size*))))
371 (with-busy-cursor (pane)
372 (update-display widget)
373 (display-inspector-pane object)
374 (list-deselect-pos widget pos))))
375
376
377
378 ;;;; The CLOS generic functions for the inspector
379
380 (defgeneric inspector-pane-title (object)
381 (:documentation
382 "Returns a string which is meant to be the title of the inspection pane
383 displaying the given object."))
384
385 (defgeneric display-inspector-pane (object)
386 (:documentation
387 "Creates a window pane which displays relevant information about the
388 given object."))
389
390
391
392 ;;;; Build the Lisp Control Panel
393
394 (defconstant *control-cookie* (cons :lisp :control))
395
396 (defvar *file-selection-hook* #'load)
397
398 (defvar *file-list* nil)
399
400 (defun file-selection-callback (widget call-data)
401 (declare (ignore widget))
402 (let ((string (compound-string-get-ltor
403 (file-selection-callback-value call-data) "")))
404 (with-callback-deferred-actions
405 (funcall *file-selection-hook* string))))
406
407 (defun add-file-callback (widget call-data fsel files)
408 (declare (ignore widget call-data))
409 (setf *file-selection-hook*
410 #'(lambda (fname)
411 (let* ((base-name (pathname-name fname))
412 (path (directory-namestring fname))
413 (name (format nil "~a~a" path base-name))
414 (xs (compound-string-create
415 (format nil "~a ~a" base-name path) "")))
416 (list-add-item files xs 1)
417 (push (cons name xs) *file-list*))))
418 (manage-child fsel))
419
420
421 (defun remove-files-callback (widget call-data files)
422 (declare (ignore widget call-data))
423 (let ((selections (list-get-selected-pos files))
424 (items))
425 (dolist (pos selections)
426 (let ((item (elt *file-list* (1- pos))))
427 (list-delete-item files (cdr item))
428 (push item items)))
429
430 (dolist (item items)
431 (setf *file-list* (delete item *file-list*)))))
432
433 (defun load-files-callback (widget call-data files)
434 (declare (ignore widget call-data))
435 (let ((selections (list-get-selected-pos files)))
436 (with-callback-deferred-actions
437 (dolist (pos selections)
438 (load (car (elt *file-list* (1- pos))))))))
439
440 (defun compile-files-callback (widget call-data files)
441 (declare (ignore widget call-data))
442 (let ((selections (list-get-selected-pos files)))
443 (with-callback-deferred-actions
444 (with-compilation-unit ()
445 (dolist (pos selections)
446 (compile-file (car (elt *file-list* (1- pos)))))))))
447
448 (defun apropos-callback (widget call-data pane)
449 (declare (ignore call-data))
450 (with-busy-cursor (pane)
451 (let* ((input (car (get-values widget :value)))
452 (results (apropos-list input)))
453 (text-set-string widget "")
454 (multiple-value-bind (form shell)
455 (create-form-dialog pane "aproposDialog")
456 (let* ((done (create-push-button form "aproposDone"
457 :left-attachment :attach-form
458 :right-attachment :attach-form
459 :label-string "Done"))
460 (list (create-scrolled-list form "aproposList"
461 :visible-item-count 10
462 :left-attachment :attach-form
463 :right-attachment :attach-form
464 :bottom-attachment :attach-form
465 :top-attachment :attach-widget
466 :top-widget done)))
467 (set-values shell :title "Apropos Results"
468 :keyboard-focus-policy :pointer)
469 (dolist (sym results)
470 (list-add-item list (symbol-name sym) 0))
471 (add-callback done :activate-callback #'destroy-callback shell)
472 (add-callback list :browse-selection-callback
473 #'(lambda (w c) (declare (ignore w))
474 (with-busy-cursor (shell)
475 (let ((pos (list-callback-item-position c)))
476 (inspect (elt results (1- pos)))))))
477 (manage-child done)
478 (manage-child list)
479 (manage-child form))))))
480
481 (defun about-callback (widget call-data pane)
482 (declare (ignore widget call-data))
483 (multiple-value-bind
484 (msg shell)
485 (create-message-dialog pane "aboutDialog"
486 :dialog-title "About Lisp"
487 :message-string (grab-output-as-string
488 (print-herald)))
489 (declare (ignore shell))
490 (let ((help (message-box-get-child msg :dialog-help-button))
491 (cancel (message-box-get-child msg :dialog-cancel-button)))
492 (destroy-widget help)
493 (destroy-widget cancel)
494 (manage-child msg))))
495
496 (defun set-compile-policy-callback (widget call-data speed space safety
497 debug cspeed brevity)
498 (declare (ignore widget call-data))
499 (flet ((get-policy-value (widget)
500 (coerce (/ (car (get-values widget :value)) 10) 'single-float)))
501 (let ((speed-val (get-policy-value speed))
502 (space-val (get-policy-value space))
503 (safety-val (get-policy-value safety))
504 (debug-val (get-policy-value debug))
505 (cspd-val (get-policy-value cspeed))
506 (brev-val (get-policy-value brevity)))
507
508 (proclaim (list 'optimize
509 (list 'speed speed-val)
510 (list 'space space-val)
511 (list 'safety safety-val)
512 (list 'debug debug-val)
513 (list 'compilation-speed cspd-val)
514 (list 'ext:inhibit-warnings brev-val))))))
515
516 (defun compile-policy-callback (widget call-data pane)
517 (declare (ignore widget call-data))
518 (multiple-value-bind (form shell)
519 (create-form-dialog pane "compilationDialog")
520 (flet ((create-policy (parent title value)
521 (create-scale parent "policy"
522 :decimal-points 1
523 :orientation :horizontal
524 :maximum 30
525 :show-value t
526 :title-string title
527 :value (truncate (* 10 value)))))
528 (let* ((cookie c::*default-cookie*)
529 (rc (create-row-column form "policies"
530 :packing :pack-column
531 :num-columns 2))
532 (speed (create-policy rc "Speed" (c::cookie-speed cookie)))
533 (space (create-policy rc "Space" (c::cookie-space cookie)))
534 (safety (create-policy rc "Safety" (c::cookie-safety cookie)))
535 (debug (create-policy rc "Debug" (c::cookie-debug cookie)))
536 (cspeed (create-policy rc "Compilation Speed"
537 (c::cookie-cspeed cookie)))
538 (brevity (create-policy rc "Inhibit Warnings"
539 (c::cookie-brevity cookie)))
540 (sep (create-separator form "separator"
541 :top-attachment :attach-widget
542 :top-widget rc
543 :left-attachment :attach-form
544 :right-attachment :attach-form))
545 (done (create-push-button form "done"
546 :label-string "Done"
547 :top-attachment :attach-widget
548 :top-widget sep
549 :left-attachment :attach-position
550 :right-attachment :attach-position
551 :left-position 35
552 :right-position 65)))
553 (set-values shell :title "Compilation Options"
554 :keyboard-focus-policy :pointer)
555 (add-callback done :activate-callback
556 'set-compile-policy-callback
557 speed space safety debug cspeed brevity)
558 (manage-children speed space safety debug cspeed brevity)
559 (manage-children sep done rc)
560 (manage-child form)))))
561
562 (defun display-control-pane ()
563 (let* ((pane (create-interface-pane-shell (lisp-implementation-type)
564 *control-cookie*))
565 (form (create-form pane "form"))
566 (fsel (create-file-selection-dialog pane "lispFileSelector"
567 :auto-unmanage t))
568 (menu-bar (create-menu-bar form "lispMenu"
569 :left-attachment :attach-form
570 :right-attachment :attach-form))
571 (lmenu (create-interface-menu
572 menu-bar "Lisp"
573 `(("About ..." about-callback ,pane)
574 "-----"
575 ("Load File" ,#'(lambda (w c)
576 (declare (ignore w c))
577 (setf *file-selection-hook* #'load)
578 (manage-child fsel)))
579 ("Compile File" ,#'(lambda (w c) (declare (ignore w c))
580 (setf *file-selection-hook*
581 #'compile-file)
582 (manage-child fsel)))
583 "-----"
584 ("Close Control Panel" ,#'popdown-callback ,pane)
585 ("Quit Lisp" ,#'(lambda (w c pane)
586 (declare (ignore w c))
587 (ask-for-confirmation
588 pane "Do you really want to quit?"
589 #'(lambda (w c) (declare (ignore w c))
590 (xt::quit-server)
591 (quit))))
592 ,pane))))
593 (fmenu (create-interface-menu
594 menu-bar "Files"
595 `(("Load File Group")
596 ("Save File Group"))))
597 (omenu (create-interface-menu
598 menu-bar "Options"
599 `(("Compilation policy ..." compile-policy-callback ,pane))))
600 (vsep (create-separator form "separator"
601 :orientation :vertical
602 :top-attachment :attach-widget
603 :top-widget menu-bar
604 :bottom-attachment :attach-form
605 :right-attachment :attach-position
606 :right-position 50))
607 (prompt (create-label form "inspectPrompt"
608 :top-attachment :attach-widget
609 :top-widget menu-bar
610 :font-list *header-font*
611 :label-string "Inspect new object:"))
612 (entry (create-text form "inspectEval"
613 :top-attachment :attach-widget
614 :top-widget prompt
615 :left-offset 4
616 :right-offset 4
617 :left-attachment :attach-form
618 :right-attachment :attach-widget
619 :right-widget vsep))
620 (hlabel (create-label form "inspectHistoryLabel"
621 :top-attachment :attach-widget
622 :top-widget entry
623 :font-list *header-font*
624 :label-string "Inspector History:"))
625 (hview (create-scrolled-list form "inspectHistory"
626 :visible-item-count 5
627 :left-offset 4
628 :right-offset 4
629 :bottom-offset 4
630 :top-attachment :attach-widget
631 :top-widget hlabel
632 :left-attachment :attach-form
633 :right-attachment :attach-widget
634 :right-widget vsep
635 :bottom-attachment :attach-form))
636 (flabel (create-label form "filesLabel"
637 :left-attachment :attach-widget
638 :left-widget vsep
639 :top-attachment :attach-widget
640 :top-widget menu-bar
641 :label-string "Files:"
642 :font-list *header-font*))
643 (frc (create-row-column form "filesButtons"
644 :packing :pack-column
645 :num-columns 2
646 :left-attachment :attach-widget
647 :left-widget vsep
648 :top-attachment :attach-widget
649 :top-widget flabel
650 :right-attachment :attach-form
651 :right-offset 4))
652 (add (create-push-button frc "fileAdd"
653 :label-string "Add File"))
654 (remove (create-push-button frc "fileRemove"
655 :label-string "Remove Files"))
656 (load (create-push-button frc "fileLoad"
657 :label-string "Load Files"))
658 (compile (create-push-button frc "fileCompile"
659 :label-string "Compile Files"))
660 (apropos (create-text form "apropos"
661 :left-attachment :attach-widget
662 :left-widget vsep
663 :right-attachment :attach-form
664 :bottom-attachment :attach-form
665 :left-offset 4
666 :right-offset 4
667 :bottom-offset 4))
668 (alabel (create-label form "aproposLabel"
669 :label-string "Apropos:"
670 :font-list *header-font*
671 :left-attachment :attach-widget
672 :left-widget vsep
673 :bottom-attachment :attach-widget
674 :bottom-widget apropos))
675 (hsep (create-separator form "separator"
676 :left-attachment :attach-widget
677 :left-widget vsep
678 :right-attachment :attach-form
679 :bottom-attachment :attach-widget
680 :bottom-widget alabel))
681 (files (create-scrolled-list form "files"
682 :visible-item-count 5
683 :selection-policy :multiple-select
684 :top-attachment :attach-widget
685 :top-widget frc
686 :left-attachment :attach-widget
687 :left-widget vsep
688 :left-offset 4
689 :right-attachment :attach-form
690 :right-offset 4
691 :bottom-attachment :attach-widget
692 :bottom-widget hsep
693 :bottom-offset 4)))
694
695 (manage-child form)
696 (manage-children lmenu fmenu omenu)
697 (manage-child files)
698 (manage-children menu-bar vsep prompt entry hlabel flabel frc
699 apropos alabel hsep)
700 (manage-children add remove load compile)
701 (manage-child hview)
702 (set-values fmenu :sensitive nil)
703
704 (setf *inspector-history* (make-inspector-history hview))
705 (setf (xti:widget-user-data entry) pane)
706
707 (add-callback entry :activate-callback #'eval-and-inspect-callback pane)
708 (add-callback hview :browse-selection-callback
709 #'inspector-history-callback pane)
710 (add-callback fsel :ok-callback 'file-selection-callback)
711 (add-callback add :activate-callback 'add-file-callback fsel files)
712 (add-callback remove :activate-callback 'remove-files-callback files)
713 (add-callback load :activate-callback 'load-files-callback files)
714 (add-callback compile :activate-callback 'compile-files-callback files)
715 (add-callback apropos :activate-callback 'apropos-callback pane)
716 (popup-interface-pane pane)
717 pane))
718
719 (defun verify-control-pane-displayed ()
720 (let ((pane (find-interface-pane *control-cookie*)))
721 (unless pane
722 (setf pane (display-control-pane)))
723 (unless (is-managed pane)
724 (popup-interface-pane pane))))
725
726 (defun lisp-control-panel ()
727 (when (use-graphics-interface)
728 (verify-system-server-exists)
729 (multiple-value-bind (shell connection)
730 (create-interface-shell)
731 (declare (ignore shell))
732 (with-motif-connection (connection)
733 (verify-control-pane-displayed)))))
734
735
736
737 ;;;; Fix up QUIT
738
739 (defun cleanup-motif ()
740 (when (and *system-motif-server*
741 (ext:process-alive-p *system-motif-server*))
742 (ext:process-kill *system-motif-server* :sigint))
743
744 (when (and xt::*local-motif-server*
745 (ext:process-alive-p xt::*local-motif-server*))
746 (ext:process-kill xt::*local-motif-server* :sigint)))
747
748 (in-package "LISP")
749
750 (defun quit (&optional recklessly-p)
751 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
752 non-Nil."
753 (if recklessly-p
754 (unix:unix-exit 0)
755 (progn
756 (interface::cleanup-motif)
757 (throw '%end-of-the-world nil))))

  ViewVC Help
Powered by ViewVC 1.1.5