source: trunk/source/examples/gtk-step.lisp @ 8441

Last change on this file since 8441 was 6, checked in by gb, 16 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2001 Clozure Associates
4;;;
5;;; Anyone who wants to use this code for any purpose is free to do so.
6;;; In doing so, the user acknowledges that this code is provided "as is",
7;;; without warranty of any kind, and that no other party is legally or
8;;; otherwise responsible for any consequences of its use.
9
10;;; A GTK+-based interface to OpenMCL's stepper.
11
12(in-package "CCL")
13
14;;;
15;;; Make GTK+ interface info available.
16(eval-when (:compile-toplevel :execute)
17  (ccl::use-interface-dir :GTK))
18
19(eval-when (:compile-toplevel :load-toplevel :execute)
20  (require "OPENMCL-GTK-SUPPORT")
21  (require "STEP"))
22
23(eval-when (:compile-toplevel :execute)
24  (defconstant gtk-step-window-command-step 1)
25  (defconstant gtk-step-window-command-step-over 2)
26  (defconstant gtk-step-window-command-go 3)
27  (defconstant gtk-step-window-command-eval 4)
28  (defconstant gtk-step-window-command-quit 5)
29  (defconstant gtk-step-window-command-window-closed 9999))
30
31(defparameter *gtk-step-window-button-commands*
32  (list gtk-step-window-command-step
33        gtk-step-window-command-step-over
34        gtk-step-window-command-go
35        gtk-step-window-command-eval
36        gtk-step-window-command-quit))
37
38;;; The callback associated with button-clicked events appends one of the
39;;; GTK-STEP-WINDOW-COMMAND- constants to a GList whose address is stored
40;;; in P.  If the contents of P are non-NULL, remove the first element
41;;; from the GList and return the command.
42(defun gtk-step-window-command (p)
43  (without-interrupts
44   (let* ((q (%get-ptr p)))
45     (declare (dynamic-extent q))
46     (unless (%null-ptr-p q)
47       (setf (%get-ptr p) (#_g_list_remove_link q q))
48       (let* ((cmd (%ptr-to-int (pref q :<GL>ist.data))))
49         (#_g_list_free_1 q)
50         cmd)))))
51
52;;; Button clicks come here; the "cmd" argument contains
53;;; the command specific to this button, encoded as a pointer.
54(defcallback gtk-step-window-button-clicked
55    (:address button :address cmd :void)
56  (with-cstrs ((qptr "qptr"))
57    (let* ((p (#_gtk_object_get_data button qptr)))
58    (declare (dynamic-extent p))
59    (unless (%null-ptr-p p)
60      (without-interrupts
61       (setf (%get-ptr p)
62             (#_g_list_append (%get-ptr p) cmd)))))))
63
64
65;;; If the step window gets closed before the stepper's finished, we
66;;; want to know that ...
67;;; The handler for the window-destroyed signal places a
68;;; GTK-STEP-WINDOW-COMMAND-WINDOW-CLOSED command at the front of
69;;; the command queue.
70(defcallback gtk-step-window-closed (:address window :address cmd :void)
71  (with-cstrs ((qptr "qptr"))
72    (let* ((p (#_gtk_object_get_data window qptr)))
73      (declare (dynamic-extent p))
74      (unless (%null-ptr-p p)
75        (without-interrupts
76         (setf (%get-ptr p)
77               (#_g_list_prepend (%get-ptr p) cmd)))))))
78
79
80(defun make-gtk-step-window ()
81  (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL)))
82    (#_gtk_widget_set_usize window 600 500)
83    (#_gtk_window_set_policy window #$TRUE #$TRUE #$FALSE)
84    (with-cstrs ((title "Step Window"))
85      (#_gtk_window_set_title window title))
86    (#_gtk_container_set_border_width window 0)
87    (let* ((box1 (#_gtk_vbox_new #$FALSE 0))
88           (box2 (#_gtk_vbox_new #$FALSE 10)))
89      (#_gtk_container_add window box1)
90      (#_gtk_widget_show box1)
91      (#_gtk_container_set_border_width box2 10)
92      (#_gtk_box_pack_start box1 box2 #$TRUE #$TRUE 0)
93      (#_gtk_widget_show box2)
94      (let* ((table (#_gtk_table_new 2 2 #$FALSE))
95             (text (#_gtk_text_new (%null-ptr) (%null-ptr))))
96        (#_gtk_text_set_editable text #$TRUE)
97        (#_gtk_text_set_line_wrap text #$TRUE)
98        (#_gtk_table_set_row_spacing table 0 2)
99        (#_gtk_table_set_col_spacing table 0 2)
100        (#_gtk_box_pack_start box2 table #$TRUE #$TRUE 0)
101        (#_gtk_widget_show table)
102        (#_gtk_table_attach table text
103                            0           ;left
104                            1           ;right
105                            0           ;top
106                            1           ;bottom
107                            (logior #$GTK_EXPAND #$GTK_SHRINK #$GTK_FILL)
108                            (logior #$GTK_EXPAND #$GTK_SHRINK #$GTK_FILL)
109                            0
110                            0)
111        (#_gtk_widget_show text)
112        (let* ((vscrollbar (#_gtk_vscrollbar_new (pref text :<G>tk<T>ext.vadj))))
113          (#_gtk_table_attach table vscrollbar
114                              1
115                              2
116                              0
117                              1
118                              #$GTK_FILL
119                              (logior #$GTK_EXPAND #$GTK_SHRINK #$GTK_FILL)
120                              0
121                              0)
122          (#_gtk_widget_show vscrollbar))
123        (#_gtk_text_thaw text)
124        (let* ((separator (#_gtk_hseparator_new)))
125          (#_gtk_box_pack_start box1 separator #$FALSE #$TRUE 0)
126          (#_gtk_widget_show separator))
127        (let* ((box3 (#_gtk_hbox_new #$FALSE 10)))
128          (#_gtk_container_set_border_width box3 10)
129          (#_gtk_box_pack_start box1 box3 #$FALSE #$TRUE 0)
130          (#_gtk_widget_show box3)
131          (with-cstrs ((step-name "Step")
132                       (step-over-name "Step over")
133                       (go-name "Go")
134                       (eval-name "Eval ...")
135                       (quit-name "Quit")
136                       (clicked "clicked")
137                       (qptr "qptr"))
138            (let* ((buttons (list                                 
139                             (#_gtk_button_new_with_label step-name)
140                             (#_gtk_button_new_with_label step-over-name)
141                             (#_gtk_button_new_with_label go-name)
142                             (#_gtk_button_new_with_label eval-name)
143                             (#_gtk_button_new_with_label quit-name)))
144                   (commands *gtk-step-window-button-commands*)
145                   (tips '("step through evaluation of form"
146                           "step over evaluation of form"
147                           "continue evaluation without stepping"
148                           "evaluate an expression in current env"
149                           "exit from the stepper (returning NIL)"))
150                   (p (#_g_malloc0 4)))
151              (declare (dynamic-extent buttons))
152              (dolist (b buttons)
153                (#_gtk_box_pack_start box3 b #$TRUE #$TRUE 0)
154                (#_gtk_object_set_data b qptr p)
155                (#_gtk_signal_connect b clicked
156                                      gtk-step-window-button-clicked
157                                      (%int-to-ptr (pop commands)))
158                (with-cstrs ((tip-text (pop tips)))
159                  (let* ((tip (#_gtk_tooltips_new )))
160                    (#_gtk_tooltips_set_tip tip b tip-text (%null-ptr))))
161                (#_gtk_widget_show b))
162              (let* ((step-button (car buttons)))
163                (setf (pref step-button :<G>tk<O>bject.flags)
164                      (logior (pref step-button :<G>tk<O>bject.flags)
165                              #$GTK_CAN_DEFAULT))
166                (#_gtk_widget_grab_default step-button))
167              (with-cstrs ((destroy "destroy"))
168                (let* ((close-signal-id
169                        (#_gtk_signal_connect window destroy
170                                              gtk-step-window-closed
171                                              (%int-to-ptr
172                                               gtk-step-window-command-window-closed))))
173                  (#_gtk_widget_show window)
174                  (values text p window close-signal-id (reverse buttons)))))))))))
175
176;;; A GTK+ user-interface to OpenMCL's stepper.
177(defclass step-gtk-window-ui (step-ui)
178    ((text :accessor step-gtk-window-ui-text)
179     (queue-ptr :accessor step-gtk-window-ui-queue-ptr)
180     (window :accessor step-gtk-window-ui-window)
181     (close-signal-id :accessor step-gtk-window-ui-close-signal-id)
182     (closed :initform nil :accessor step-gtk-window-ui-closed)
183     (finished :initform nil :accessor step-gtk-window-ui-finished)
184     (buttons :initform nil :accessor step-gtk-window-ui-buttons)
185     (normal-font :initform nil)
186     (bold-font :initform nil)))
187
188(defun ui-output-formatted-string (ui string font-id)
189  (unless (step-gtk-window-ui-closed ui)
190    (let* ((text (step-gtk-window-ui-text ui))
191           (vadj (pref text :<G>tk<T>ext.vadj))
192           (font (if (eql 2 font-id)
193                   (slot-value ui 'bold-font)
194                   (slot-value ui 'normal-font))))
195      (with-cstrs ((string string))
196        (#_gtk_text_freeze text)
197        (#_gtk_text_insert text font (pref text :<G>tk<W>idget.style.black)
198                           (%null-ptr) string -1)
199        (#_gtk_text_set_point text (#_gtk_text_get_length text))
200        (unless (%null-ptr-p vadj)
201          (#_gtk_adjustment_set_value vadj (pref vadj :<G>tk<A>djustment.upper)))
202        (#_gtk_text_thaw text)))))
203
204(defmethod step-prin1 ((ui step-gtk-window-ui) form font &optional prefix)
205  (ui-output-formatted-string
206   ui
207   (with-output-to-string
208     (stream)
209     (let ((*print-level* *step-print-level*)
210           (*print-length* *step-print-length*)
211           (*print-readably* nil)
212           (*print-array* nil)
213           (*print-case* :downcase))
214       (when prefix (princ prefix stream))
215       (prin1 form stream)))
216   font))
217
218(defmethod step-tab ((ui step-gtk-window-ui))
219  (ui-output-formatted-string
220   ui
221   (with-output-to-string
222     (stream)
223     (terpri stream)
224     (dotimes (i (min *step-level* *trace-max-indent*))
225       (write-char #\Space stream)))
226   1))
227
228(defmethod step-show-error ((ui step-gtk-window-ui) err)
229  (ui-output-formatted-string
230   ui
231   (with-output-to-string
232     (stream)
233     (step-tab ui)
234     (princ "Error >> " stream)
235     (format stream "~A" err))
236   1))
237
238(defmethod initialize-instance ((ui step-gtk-window-ui) &key)
239  (multiple-value-bind (text ptr window signal-id buttons)
240      (make-gtk-step-window)
241    (setf (step-gtk-window-ui-text ui) text
242          (step-gtk-window-ui-queue-ptr ui) ptr
243          (step-gtk-window-ui-window ui) window
244          (step-gtk-window-ui-close-signal-id ui) signal-id
245          (step-gtk-window-ui-buttons ui) buttons
246          (step-gtk-window-ui-finished ui) nil
247          (step-gtk-window-ui-closed ui) nil)
248    (with-cstrs ((medium "-misc-fixed-medium-r-*-*-*-120-*-*-*-*-*-*")
249                 (bold   "-misc-fixed-bold-r-*-*-*-120-*-*-*-*-*"))
250      (setf (slot-value ui 'normal-font) (#_gdk_font_load medium)
251            (slot-value ui 'bold-font) (#_gdk_font_load bold)))))
252
253(defmethod step-ask ((ui step-gtk-window-ui))
254  (let* ((qptr (step-gtk-window-ui-queue-ptr ui))
255         (cmd nil)
256         (wait-function #'(lambda ()
257                            (let* ((c (gtk-step-window-command qptr)))
258                              (when c
259                                (setq cmd c))))))
260    (declare (dynamic-extent wait-function))
261    (process-wait "step command wait" wait-function)
262    (cond
263      ((eql cmd gtk-step-window-command-step) :step)
264      ((eql cmd gtk-step-window-command-step-over) :step-over)
265      ((eql cmd gtk-step-window-command-go) :go)
266      ((eql cmd gtk-step-window-command-eval) :eval)
267      ((eql cmd gtk-step-window-command-quit) :quit)
268      (t :quit))))
269
270(defmethod step-ui-finish ((ui step-gtk-window-ui))
271  (unless (step-gtk-window-ui-finished ui)
272    (setf (step-gtk-window-ui-finished ui) t)
273    (let* ((window (step-gtk-window-ui-window ui)))
274      (#_gtk_signal_disconnect window
275                               (step-gtk-window-ui-close-signal-id ui))
276      (let*  ((buttons (prog1
277                           (step-gtk-window-ui-buttons ui)
278                         (setf (step-gtk-window-ui-buttons ui) nil)))
279              (parent (pref (car buttons) :<G>tk<W>idget.parent)))
280        (with-cstrs ((close "Close")
281                     (clicked "clicked"))
282          (let* ((close-button (#_gtk_button_new_with_label close)))
283            (#_gtk_signal_connect_object close-button clicked
284                                         (foreign-symbol-address
285                                          "gtk_widget_destroy")
286                                         window)
287            (#_gtk_box_pack_start parent close-button #$TRUE #$TRUE 0)
288            (dolist (b buttons)
289              (#_gtk_widget_destroy b))
290            (#_gtk_widget_show close-button)))))))
291
292
293
294;;; Prompt for a string, via a GtkEntry widget.
295;;;
296
297;;; Tell lisp that the dialog's closed (for whatever reason.)
298(defcallback gtk-get-string-dialog-closed
299    (:address dialog :address info-ptr :void)
300  (declare (ignore dialog))
301  (setf (%get-ptr info-ptr 0) (%null-ptr)))
302
303;;; String is ready.
304(defcallback gtk-get-string-dialog-get-string
305    (:address entry :address info-ptr :void)
306  (setf (%get-ptr info-ptr 4) (#_g_strdup (#_gtk_entry_get_text entry)))
307  ;;; Close the dialog.
308  (#_gtk_widget_destroy (%get-ptr info-ptr 0)))
309
310(defun gtk-get-string-from-user (prompt)
311  (%stack-block ((info-ptr 12))
312    (setf (%get-ptr info-ptr 0) (%null-ptr) ; backptr to window
313          (%get-ptr info-ptr 4) (%null-ptr)) ;string ptr
314    (let* ((dialog-window (#_gtk_window_new #$GTK_WINDOW_DIALOG))
315           (vbox (#_gtk_vbox_new #$FALSE 0)))
316      (setf (%get-ptr info-ptr 0) dialog-window)
317      (#_gtk_container_add dialog-window vbox)
318      (#_gtk_widget_show vbox)
319      (with-cstrs  ((destroy "destroy")
320                    (activate "activate")
321                    (prompt prompt))
322        (#_gtk_signal_connect dialog-window destroy
323                              gtk-get-string-dialog-closed info-ptr)
324        (#_gtk_widget_set_usize dialog-window 400 80)
325        (let* ((label (#_gtk_label_new prompt))
326               (entry (#_gtk_entry_new)))
327          (#_gtk_box_pack_start vbox label #$TRUE #$TRUE 0)
328          (#_gtk_widget_show label)
329          (#_gtk_entry_set_max_length entry #x0000ffff)
330          (#_gtk_signal_connect entry activate gtk-get-string-dialog-get-string
331                                info-ptr)
332          (#_gtk_box_pack_end vbox entry #$TRUE #$TRUE 0)
333          (#_gtk_widget_show entry)
334          (#_gtk_widget_show dialog-window))
335        (process-wait "text entry" #'(lambda () (%null-ptr-p (%get-ptr info-ptr 0))))
336        (let* ((strptr (%get-ptr info-ptr 4))
337               (string ()))
338          (unless (%null-ptr-p strptr)
339            (unless (zerop (%get-byte strptr))
340              (setq string (%get-cstring strptr))
341              (#_g_free strptr)))
342          string)))))
343
344(defmethod step-prompt-for-string ((ui step-gtk-window-ui) prompt)
345  (gtk-get-string-from-user prompt))
346       
347
348(setq *default-step-ui-class-name* 'step-gtk-window-ui)
349
350
351
Note: See TracBrowser for help on using the repository browser.