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

Contents of /src/interface/interface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5