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

Contents of /src/interface/interface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Fri Feb 11 20:58:14 1994 UTC (20 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.5: +27 -12 lines
Tried to make starting the Motif server more robust, or at least give some
intelligible error message.
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 (defvar *server-startup-timeout* 30)
293
294 (defun verify-system-server-exists ()
295 (when (and (not xt:*default-server-host*)
296 (or (not *system-motif-server*)
297 (and *system-motif-server*
298 (not (ext:process-alive-p *system-motif-server*)))))
299 (let ((process (ext:run-program
300 (merge-pathnames *clm-binary-name*
301 *clm-binary-directory*)
302 '("-nofork" "-local")
303 :output *error-output*
304 :error :output
305 :wait nil
306 :status-hook #'system-server-status-hook)))
307 (unless (and process (ext:process-alive-p process))
308 (xti:toolkit-error "Could not start Motif server process.~@
309 Status = ~S, exit code = ~D."
310 (ext:process-status process)
311 (ext:process-exit-code process)))
312 ;;
313 ;; Wait until the server has started up
314 (let ((sock-name (format nil "/tmp/.motif_socket-p~D"
315 (ext:process-pid process)))
316 (end-time (+ (get-internal-real-time)
317 (* internal-time-units-per-second
318 *server-startup-timeout*))))
319 (loop
320 (when (probe-file sock-name)
321 (return))
322 (system:serve-event 1)
323 (when (> (get-internal-real-time) end-time)
324 (xti:toolkit-error
325 "Timed out waiting for Motif server to start up.")))
326 (setf *system-motif-server* process)))))
327
328
329
330 ;;;; Handling of the Inspector items in the Control Panel
331
332 (defconstant *history-size* 25)
333
334 (defvar *inspector-history*)
335 (defvar *current-inspector-objects* nil)
336
337 (defstruct (inspector-history
338 (:print-function print-inspector-history)
339 (:conc-name history-)
340 (:constructor make-inspector-history (widget)))
341 (record (make-array *history-size*) :type simple-vector)
342 (head 0 :type fixnum)
343 (tail 0 :type fixnum)
344 (widget nil :type (or nil widget)))
345
346 (defun print-inspector-history (hist stream d)
347 (declare (ignore hist d))
348 (write-string "#<Inspector History>" stream))
349
350 (defun inspector-add-history-item (object)
351 (let* ((h *inspector-history*)
352 (tail (history-tail h))
353 (head (history-head h))
354 (widget (history-widget h)))
355 ;;
356 ;; Only add new items to the history if they're not there already
357 (unless (position object (history-record h))
358 (setf (svref (history-record h) tail) object)
359 (setf tail (mod (1+ tail) *history-size*))
360 (setf (history-tail h) tail)
361 ;;
362 ;; Add new item at the top of the history list
363 (list-add-item widget (print-for-widget-display "~S" object) 1)
364 (when (= tail head)
365 (setf (history-head h) (mod (1+ head) *history-size*))
366 ;;
367 ;; Nuke old item at bottom of history
368 (list-delete-pos widget 0)))))
369
370 (defun eval-and-inspect-callback (widget call-data pane)
371 (declare (ignore call-data))
372 (let ((input (car (get-values widget :value))))
373 (handler-case
374 (let ((object (eval (read-from-string input))))
375 (with-busy-cursor (pane)
376 (text-set-string widget "")
377 (display-inspector-pane object)
378 (push object *current-inspector-objects*)
379 (inspector-add-history-item object)))
380 (error (e)
381 (interface-error (format nil "~a" e) (xti:widget-user-data widget))))))
382
383 (defun inspector-history-callback (widget call-data pane)
384 (let* ((pos (list-callback-item-position call-data))
385 (object (svref (history-record *inspector-history*)
386 (mod (- (history-tail *inspector-history*) pos)
387 *history-size*))))
388 (with-busy-cursor (pane)
389 (update-display widget)
390 (display-inspector-pane object)
391 (push object *current-inspector-objects*)
392 (list-deselect-pos widget pos))))
393
394
395
396 ;;;; The CLOS generic functions for the inspector
397
398 (defgeneric inspector-pane-title (object)
399 (:documentation
400 "Returns a string which is meant to be the title of the inspection pane
401 displaying the given object."))
402
403 (defgeneric display-inspector-pane (object)
404 (:documentation
405 "Creates a window pane which displays relevant information about the
406 given object."))
407
408
409
410 ;;;; Build the Lisp Control Panel
411
412 (defconstant *control-cookie* (cons :lisp :control))
413
414 (defvar *file-selection-hook* #'load)
415
416 (defvar *file-list* nil)
417
418 (defun close-all-callback (widget call-data)
419 (declare (ignore widget call-data))
420 (dolist (object *current-inspector-objects*)
421 (destroy-interface-pane object))
422 (setf *current-inspector-objects* nil))
423
424 (defun file-selection-callback (widget call-data)
425 (declare (ignore widget))
426 (let ((string (compound-string-get-ltor
427 (file-selection-callback-value call-data) "")))
428 (with-callback-deferred-actions
429 (funcall *file-selection-hook* string))))
430
431 (defun add-file-callback (widget call-data fsel files)
432 (declare (ignore widget call-data))
433 (setf *file-selection-hook*
434 #'(lambda (fname)
435 (let* ((base-name (pathname-name fname))
436 (path (directory-namestring fname))
437 (name (format nil "~a~a" path base-name))
438 (xs (compound-string-create
439 (format nil "~a ~a" base-name path) "")))
440 (list-add-item files xs 1)
441 (push (cons name xs) *file-list*))))
442 (manage-child fsel))
443
444
445 (defun remove-files-callback (widget call-data files)
446 (declare (ignore widget call-data))
447 (let ((selections (list-get-selected-pos files))
448 (items))
449 (dolist (pos selections)
450 (let ((item (elt *file-list* (1- pos))))
451 (list-delete-item files (cdr item))
452 (push item items)))
453
454 (dolist (item items)
455 (setf *file-list* (delete item *file-list*)))))
456
457 (defun load-files-callback (widget call-data files)
458 (declare (ignore widget call-data))
459 (let ((selections (list-get-selected-pos files)))
460 (with-callback-deferred-actions
461 (dolist (pos selections)
462 (load (car (elt *file-list* (1- pos))))))))
463
464 (defun compile-files-callback (widget call-data files)
465 (declare (ignore widget call-data))
466 (let ((selections (list-get-selected-pos files)))
467 (with-callback-deferred-actions
468 (with-compilation-unit ()
469 (dolist (pos selections)
470 (compile-file (car (elt *file-list* (1- pos)))))))))
471
472 (defun apropos-callback (widget call-data pane)
473 (declare (ignore call-data))
474 (with-busy-cursor (pane)
475 (let* ((input (car (get-values widget :value)))
476 (results (apropos-list input)))
477 (text-set-string widget "")
478 (multiple-value-bind (form shell)
479 (create-form-dialog pane "aproposDialog")
480 (let* ((done (create-push-button form "aproposDone"
481 :left-attachment :attach-form
482 :right-attachment :attach-form
483 :label-string "Done"))
484 (list (create-scrolled-list form "aproposList"
485 :visible-item-count 10
486 :left-attachment :attach-form
487 :right-attachment :attach-form
488 :bottom-attachment :attach-form
489 :top-attachment :attach-widget
490 :top-widget done)))
491 (set-values shell :title "Apropos Results"
492 :keyboard-focus-policy :pointer)
493 (dolist (sym results)
494 (list-add-item list (symbol-name sym) 0))
495 (add-callback done :activate-callback #'destroy-callback shell)
496 (add-callback list :browse-selection-callback
497 #'(lambda (w c) (declare (ignore w))
498 (with-busy-cursor (shell)
499 (let ((pos (list-callback-item-position c)))
500 (inspect (elt results (1- pos)))))))
501 (manage-child done)
502 (manage-child list)
503 (manage-child form))))))
504
505 (defun about-callback (widget call-data pane)
506 (declare (ignore widget call-data))
507 (multiple-value-bind
508 (msg shell)
509 (create-message-dialog pane "aboutDialog"
510 :dialog-title "About Lisp"
511 :message-string (grab-output-as-string
512 (print-herald)))
513 (declare (ignore shell))
514 (let ((help (message-box-get-child msg :dialog-help-button))
515 (cancel (message-box-get-child msg :dialog-cancel-button)))
516 (destroy-widget help)
517 (destroy-widget cancel)
518 (manage-child msg))))
519
520 (defun set-compile-policy-callback (widget call-data speed space safety
521 debug cspeed brevity)
522 (declare (ignore widget call-data))
523 (flet ((get-policy-value (widget)
524 (coerce (/ (car (get-values widget :value)) 10) 'single-float)))
525 (let ((speed-val (get-policy-value speed))
526 (space-val (get-policy-value space))
527 (safety-val (get-policy-value safety))
528 (debug-val (get-policy-value debug))
529 (cspd-val (get-policy-value cspeed))
530 (brev-val (get-policy-value brevity)))
531
532 (proclaim (list 'optimize
533 (list 'speed speed-val)
534 (list 'space space-val)
535 (list 'safety safety-val)
536 (list 'debug debug-val)
537 (list 'compilation-speed cspd-val)
538 (list 'ext:inhibit-warnings brev-val))))))
539
540 (defun compile-policy-callback (widget call-data pane)
541 (declare (ignore widget call-data))
542 (multiple-value-bind (form shell)
543 (create-form-dialog pane "compilationDialog")
544 (flet ((create-policy (parent title value)
545 (create-scale parent "policy"
546 :decimal-points 1
547 :orientation :horizontal
548 :maximum 30
549 :show-value t
550 :title-string title
551 :value (truncate (* 10 value)))))
552 (let* ((cookie c::*default-cookie*)
553 (rc (create-row-column form "policies"
554 :packing :pack-column
555 :num-columns 2))
556 (speed (create-policy rc "Speed" (c::cookie-speed cookie)))
557 (space (create-policy rc "Space" (c::cookie-space cookie)))
558 (safety (create-policy rc "Safety" (c::cookie-safety cookie)))
559 (debug (create-policy rc "Debug" (c::cookie-debug cookie)))
560 (cspeed (create-policy rc "Compilation Speed"
561 (c::cookie-cspeed cookie)))
562 (brevity (create-policy rc "Inhibit Warnings"
563 (c::cookie-brevity cookie)))
564 (sep (create-separator form "separator"
565 :top-attachment :attach-widget
566 :top-widget rc
567 :left-attachment :attach-form
568 :right-attachment :attach-form))
569 (done (create-push-button form "done"
570 :label-string "Done"
571 :top-attachment :attach-widget
572 :top-widget sep
573 :left-attachment :attach-position
574 :right-attachment :attach-position
575 :left-position 35
576 :right-position 65)))
577 (set-values shell :title "Compilation Options"
578 :keyboard-focus-policy :pointer)
579 (add-callback done :activate-callback
580 'set-compile-policy-callback
581 speed space safety debug cspeed brevity)
582 (manage-children speed space safety debug cspeed brevity)
583 (manage-children sep done rc)
584 (manage-child form)))))
585
586 (defun display-control-pane ()
587 (let* ((pane (create-interface-pane-shell (lisp-implementation-type)
588 *control-cookie*))
589 (form (create-form pane "form"))
590 (fsel (create-file-selection-dialog pane "lispFileSelector"
591 :auto-unmanage t))
592 (menu-bar (create-menu-bar form "lispMenu"
593 :left-attachment :attach-form
594 :right-attachment :attach-form))
595 (lmenu (create-interface-menu
596 menu-bar "Lisp"
597 `(("About ..." about-callback ,pane)
598 "-----"
599 ("Load File" ,#'(lambda (w c)
600 (declare (ignore w c))
601 (setf *file-selection-hook* #'load)
602 (manage-child fsel)))
603 ("Compile File" ,#'(lambda (w c) (declare (ignore w c))
604 (setf *file-selection-hook*
605 #'compile-file)
606 (manage-child fsel)))
607 "-----"
608 ("Close Inspection Panes" ,#'close-all-callback)
609 ("Close Control Panel" ,#'popdown-callback ,pane)
610 ("Quit Lisp" ,#'(lambda (w c pane)
611 (declare (ignore w c))
612 (ask-for-confirmation
613 pane "Do you really want to quit?"
614 #'(lambda (w c) (declare (ignore w c))
615 (xt::quit-server)
616 (quit))))
617 ,pane))))
618 (fmenu (create-interface-menu
619 menu-bar "Files"
620 `(("Load File Group")
621 ("Save File Group"))))
622 (omenu (create-interface-menu
623 menu-bar "Options"
624 `(("Compilation policy ..." compile-policy-callback ,pane))))
625 (vsep (create-separator form "separator"
626 :orientation :vertical
627 :top-attachment :attach-widget
628 :top-widget menu-bar
629 :bottom-attachment :attach-form
630 :right-attachment :attach-position
631 :right-position 50))
632 (prompt (create-label form "inspectPrompt"
633 :top-attachment :attach-widget
634 :top-widget menu-bar
635 :font-list *header-font*
636 :label-string "Inspect new object:"))
637 (entry (create-text form "inspectEval"
638 :top-attachment :attach-widget
639 :top-widget prompt
640 :left-offset 4
641 :right-offset 4
642 :left-attachment :attach-form
643 :right-attachment :attach-widget
644 :right-widget vsep))
645 (hlabel (create-label form "inspectHistoryLabel"
646 :top-attachment :attach-widget
647 :top-widget entry
648 :font-list *header-font*
649 :label-string "Inspector History:"))
650 (hview (create-scrolled-list form "inspectHistory"
651 :visible-item-count 5
652 :left-offset 4
653 :right-offset 4
654 :bottom-offset 4
655 :top-attachment :attach-widget
656 :top-widget hlabel
657 :left-attachment :attach-form
658 :right-attachment :attach-widget
659 :right-widget vsep
660 :bottom-attachment :attach-form))
661 (flabel (create-label form "filesLabel"
662 :left-attachment :attach-widget
663 :left-widget vsep
664 :top-attachment :attach-widget
665 :top-widget menu-bar
666 :label-string "Files:"
667 :font-list *header-font*))
668 (frc (create-row-column form "filesButtons"
669 :packing :pack-column
670 :num-columns 2
671 :left-attachment :attach-widget
672 :left-widget vsep
673 :top-attachment :attach-widget
674 :top-widget flabel
675 :right-attachment :attach-form
676 :right-offset 4))
677 (add (create-push-button frc "fileAdd"
678 :label-string "Add File"))
679 (remove (create-push-button frc "fileRemove"
680 :label-string "Remove Files"))
681 (load (create-push-button frc "fileLoad"
682 :label-string "Load Files"))
683 (compile (create-push-button frc "fileCompile"
684 :label-string "Compile Files"))
685 (apropos (create-text form "apropos"
686 :left-attachment :attach-widget
687 :left-widget vsep
688 :right-attachment :attach-form
689 :bottom-attachment :attach-form
690 :left-offset 4
691 :right-offset 4
692 :bottom-offset 4))
693 (alabel (create-label form "aproposLabel"
694 :label-string "Apropos:"
695 :font-list *header-font*
696 :left-attachment :attach-widget
697 :left-widget vsep
698 :bottom-attachment :attach-widget
699 :bottom-widget apropos))
700 (hsep (create-separator form "separator"
701 :left-attachment :attach-widget
702 :left-widget vsep
703 :right-attachment :attach-form
704 :bottom-attachment :attach-widget
705 :bottom-widget alabel))
706 (files (create-scrolled-list form "files"
707 :visible-item-count 5
708 :selection-policy :multiple-select
709 :top-attachment :attach-widget
710 :top-widget frc
711 :left-attachment :attach-widget
712 :left-widget vsep
713 :left-offset 4
714 :right-attachment :attach-form
715 :right-offset 4
716 :bottom-attachment :attach-widget
717 :bottom-widget hsep
718 :bottom-offset 4)))
719
720 (manage-child form)
721 (manage-children lmenu fmenu omenu)
722 (manage-child files)
723 (manage-children menu-bar vsep prompt entry hlabel flabel frc
724 apropos alabel hsep)
725 (manage-children add remove load compile)
726 (manage-child hview)
727 (set-values fmenu :sensitive nil)
728
729 (setf *inspector-history* (make-inspector-history hview))
730 (setf (xti:widget-user-data entry) pane)
731
732 (add-callback entry :activate-callback #'eval-and-inspect-callback pane)
733 (add-callback hview :browse-selection-callback
734 #'inspector-history-callback pane)
735 (add-callback fsel :ok-callback 'file-selection-callback)
736 (add-callback add :activate-callback 'add-file-callback fsel files)
737 (add-callback remove :activate-callback 'remove-files-callback files)
738 (add-callback load :activate-callback 'load-files-callback files)
739 (add-callback compile :activate-callback 'compile-files-callback files)
740 (add-callback apropos :activate-callback 'apropos-callback pane)
741 (popup-interface-pane pane)
742 pane))
743
744 (defun verify-control-pane-displayed ()
745 (let ((pane (find-interface-pane *control-cookie*)))
746 (unless pane
747 (setf pane (display-control-pane)))
748 (unless (is-managed pane)
749 (popup-interface-pane pane))))
750
751 (defun lisp-control-panel ()
752 (when (use-graphics-interface)
753 (verify-system-server-exists)
754 (multiple-value-bind (shell connection)
755 (create-interface-shell)
756 (declare (ignore shell))
757 (with-motif-connection (connection)
758 (verify-control-pane-displayed)))))
759
760
761
762 ;;;; Fix up QUIT
763
764 (defun cleanup-motif ()
765 (when (and *system-motif-server*
766 (ext:process-alive-p *system-motif-server*))
767 (ext:process-kill *system-motif-server* :sigint))
768
769 (when (and xt::*local-motif-server*
770 (ext:process-alive-p xt::*local-motif-server*))
771 (ext:process-kill xt::*local-motif-server* :sigint)))
772
773 (in-package "LISP")
774
775 (defun quit (&optional recklessly-p)
776 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
777 non-Nil."
778 (if recklessly-p
779 (unix:unix-exit 0)
780 (progn
781 (interface::cleanup-motif)
782 (throw '%end-of-the-world nil))))

  ViewVC Help
Powered by ViewVC 1.1.5