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

Contents of /src/interface/interface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Thu Feb 22 20:28:53 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
Changes since 1.10: +3 -3 lines
From Paul Foley

A couple of typo corrections; fix main() in lisp.c (main returns int,
not void!); stop ACCEPT-TCP-CONNECTION blocking other processes.
1 garland 1.1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2     ;;;
3 garland 1.4 ;;; **********************************************************************
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 ram 1.9 ;;;
7     (ext:file-comment
8 pw 1.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/interface/interface.lisp,v 1.11 2001/02/22 20:28:53 pw Exp $")
9 garland 1.4 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; Written by Michael Garland
13     ;;;
14 garland 1.1 ;;; 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 garland 1.4 ;;;
18 garland 1.1
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 garland 1.3 (let ((widget (create-push-button pulldown "menuEntry"
148 garland 1.1 :label-string (car entry))))
149     (when (cdr entry)
150     (apply #'add-callback widget :activate-callback (cdr entry)))
151     (push widget widgets))
152 garland 1.3 (let ((widget (create-separator pulldown "menuSeparator")))
153 garland 1.1 (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 garland 1.3 (create-push-button parent name
165 garland 1.1 :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 garland 1.3 (label (create-label rc "valueLabel"
196 garland 1.1 :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 garland 1.3 (create-label rc "valueObject"
203 garland 1.1 :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 garland 1.3 (:push-button
221 garland 1.1 (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 garland 1.3 (:label
227 garland 1.1 (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 garland 1.2 ((not (assoc :display ext:*environment-list*)) nil)
272     ((member kind '(:window :windows :graphics :graphical :x)) t)
273 garland 1.1 ((member kind '(:command-line :tty)) nil)
274     (t
275 garland 1.2 (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 garland 1.1
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 ram 1.8 (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 garland 1.1
295 ram 1.6 (defvar *server-startup-timeout* 30)
296    
297 garland 1.1 (defun verify-system-server-exists ()
298     (when (and (not xt:*default-server-host*)
299 ram 1.7 (not (and *system-motif-server*
300     (ext:process-alive-p *system-motif-server*))))
301 ram 1.6 (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 garland 1.1 (unless (and process (ext:process-alive-p process))
310 ram 1.6 (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 garland 1.1 ;;
315     ;; Wait until the server has started up
316 ram 1.6 (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 ram 1.7
329 ram 1.6 (setf *system-motif-server* process)))))
330 garland 1.1
331    
332    
333     ;;;; Handling of the Inspector items in the Control Panel
334    
335     (defconstant *history-size* 25)
336    
337     (defvar *inspector-history*)
338 garland 1.5 (defvar *current-inspector-objects* nil)
339 garland 1.1
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 garland 1.5 (push object *current-inspector-objects*)
382 garland 1.1 (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 garland 1.5 (push object *current-inspector-objects*)
395 garland 1.1 (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 garland 1.5 (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 garland 1.1 (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 garland 1.3 (let* ((done (create-push-button form "aproposDone"
484 garland 1.1 :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 garland 1.3 (sep (create-separator form "separator"
568 garland 1.1 :top-attachment :attach-widget
569     :top-widget rc
570     :left-attachment :attach-form
571     :right-attachment :attach-form))
572 garland 1.3 (done (create-push-button form "done"
573 garland 1.1 :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 garland 1.5 ("Close Inspection Panes" ,#'close-all-callback)
612 garland 1.1 ("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 garland 1.3 (prompt (create-label form "inspectPrompt"
636 garland 1.1 :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 garland 1.3 (hlabel (create-label form "inspectHistoryLabel"
649 garland 1.1 :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 garland 1.3 (flabel (create-label form "filesLabel"
665 garland 1.1 :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 garland 1.3 (add (create-push-button frc "fileAdd"
681 garland 1.1 :label-string "Add File"))
682 garland 1.3 (remove (create-push-button frc "fileRemove"
683 garland 1.1 :label-string "Remove Files"))
684 garland 1.3 (load (create-push-button frc "fileLoad"
685 garland 1.1 :label-string "Load Files"))
686 garland 1.3 (compile (create-push-button frc "fileCompile"
687 garland 1.1 :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 garland 1.3 (alabel (create-label form "aproposLabel"
697 garland 1.1 :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 garland 1.3 (hsep (create-separator form "separator"
704 garland 1.1 :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 garland 1.4 (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 pw 1.11 (in-package "EXT")
777 garland 1.4
778     (defun quit (&optional recklessly-p)
779     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
780     non-Nil."
781     (if recklessly-p
782     (unix:unix-exit 0)
783     (progn
784     (interface::cleanup-motif)
785 pw 1.11 (throw 'cl::%end-of-the-world 0))))

  ViewVC Help
Powered by ViewVC 1.1.5