|
462
|
1 (require 'gtk-ffi)
|
|
|
2
|
|
|
3 (defconst GTK_TYPE_INVALID 0)
|
|
|
4 (defconst GTK_TYPE_NONE 1)
|
|
|
5 (defconst GTK_TYPE_CHAR 2)
|
|
|
6 (defconst GTK_TYPE_UCHAR 3)
|
|
|
7 (defconst GTK_TYPE_BOOL 4)
|
|
|
8 (defconst GTK_TYPE_INT 5)
|
|
|
9 (defconst GTK_TYPE_UINT 6)
|
|
|
10 (defconst GTK_TYPE_LONG 7)
|
|
|
11 (defconst GTK_TYPE_ULONG 8)
|
|
|
12 (defconst GTK_TYPE_FLOAT 9)
|
|
|
13 (defconst GTK_TYPE_DOUBLE 10)
|
|
|
14 (defconst GTK_TYPE_STRING 11)
|
|
|
15 (defconst GTK_TYPE_ENUM 12)
|
|
|
16 (defconst GTK_TYPE_FLAGS 13)
|
|
|
17 (defconst GTK_TYPE_BOXED 14)
|
|
|
18 (defconst GTK_TYPE_POINTER 15)
|
|
|
19 (defconst GTK_TYPE_SIGNAL 16)
|
|
|
20 (defconst GTK_TYPE_ARGS 17)
|
|
|
21 (defconst GTK_TYPE_CALLBACK 18)
|
|
|
22 (defconst GTK_TYPE_C_CALLBACK 19)
|
|
|
23 (defconst GTK_TYPE_FOREIGN 20)
|
|
|
24 (defconst GTK_TYPE_OBJECT 21)
|
|
|
25
|
|
|
26 (defconst gtk-value-accessor-names
|
|
|
27 '("INVALID" "NONE" "CHAR" "UCHAR" "BOOL" "INT" "UINT" "LONG" "ULONG" "FLOAT" "DOUBLE"
|
|
|
28 "STRING" "ENUM" "FLAGS" "BOXED" "POINTER" "SIGNAL" "ARGS" "CALLBACK" "C_CALLBACK"
|
|
|
29 "FOREIGN" "OBJECT"))
|
|
|
30
|
|
|
31 (defun define-widget-accessors (gtk-class
|
|
|
32 wrapper
|
|
|
33 prefix args)
|
|
|
34 "Output stub C code to access parts of a widget from lisp.
|
|
|
35 GTK-CLASS is the GTK class to grant access to.
|
|
|
36 WRAPPER is a fragment to construct GTK C macros for typechecking/etc. (ie: WIDGET)
|
|
|
37 ARGS is a list of (type . name) cons cells.
|
|
|
38 Defines a whole slew of functions to access & set the slots in the
|
|
|
39 structure."
|
|
|
40 (set-buffer (get-buffer-create "emacs-widget-accessors.c"))
|
|
|
41 (goto-char (point-max))
|
|
|
42 (let ((arg)
|
|
|
43 (base-arg-type nil)
|
|
|
44 (lisp-func-name nil)
|
|
|
45 (c-func-name nil)
|
|
|
46 (func-names nil))
|
|
|
47 (setq gtk-class (symbol-name gtk-class)
|
|
|
48 wrapper (upcase wrapper))
|
|
|
49 (while (setq arg (pop args))
|
|
|
50 (setq lisp-func-name (format "gtk-%s-%s" prefix (cdr arg))
|
|
|
51 lisp-func-name (replace-in-string lisp-func-name "_" "-")
|
|
|
52 c-func-name (concat "F" (replace-in-string lisp-func-name "-" "_")))
|
|
|
53 (insert
|
|
|
54 "DEFUN (\"" lisp-func-name "\", " c-func-name ", 1, 1, 0, /*\n"
|
|
|
55 "Access the `" (symbol-name (cdr arg)) "' slot of OBJ, a " gtk-class " object.\n"
|
|
|
56 "*/\n"
|
|
|
57 "\t(obj))\n"
|
|
|
58 "{\n"
|
|
|
59 (format "\t%s *the_obj = NULL;\n" gtk-class)
|
|
|
60 "\tGtkArg arg;\n"
|
|
|
61 "\n"
|
|
|
62 "\tCHECK_GTK_OBJECT (obj);\n"
|
|
|
63 "\n"
|
|
|
64 (format "\tif (!GTK_IS_%s (XGTK_OBJECT (obj)->object))\n" wrapper)
|
|
|
65 "\t{\n"
|
|
|
66 (format "\t\tsignal_simple_error (\"Object is not a %s\", obj);\n" gtk-class)
|
|
|
67 "\t};\n"
|
|
|
68 "\n"
|
|
|
69 (format "\tthe_obj = GTK_%s (XGTK_OBJECT (obj)->object);\n" wrapper)
|
|
|
70
|
|
|
71 (format "\targ.type = gtk_type_from_name (\"%s\");\n" (symbol-name (car arg))))
|
|
|
72 ; (format "\targ.type = GTK_TYPE_%s;\n" (or
|
|
|
73 ; (nth (gtk-fundamental-type (car arg))
|
|
|
74 ; gtk-value-accessor-names)
|
|
|
75 ; (case (car arg)
|
|
|
76 ; (GtkListOfString "STRING_LIST")
|
|
|
77 ; (GtkListOfObject "OBJECT_LIST")
|
|
|
78 ; (otherwise
|
|
|
79 ; "POINTER")))))
|
|
|
80
|
|
|
81 (setq base-arg-type (gtk-fundamental-type (car arg)))
|
|
|
82 (cond
|
|
|
83 ((= base-arg-type GTK_TYPE_OBJECT)
|
|
|
84 (insert
|
|
|
85 (format "\tGTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->%s);"
|
|
|
86 (cdr arg))))
|
|
|
87 ((or (= base-arg-type GTK_TYPE_POINTER)
|
|
|
88 (= base-arg-type GTK_TYPE_BOXED))
|
|
|
89 (insert
|
|
|
90 (format "\tGTK_VALUE_%s (arg) = (void *)the_obj->%s;"
|
|
|
91 (nth (gtk-fundamental-type (car arg)) gtk-value-accessor-names)
|
|
|
92 (cdr arg))))
|
|
|
93 (t
|
|
|
94 (insert
|
|
|
95 (format "\tGTK_VALUE_%s (arg) = the_obj->%s;"
|
|
|
96 (or (nth (gtk-fundamental-type (car arg)) gtk-value-accessor-names) "POINTER")
|
|
|
97 (cdr arg)))))
|
|
|
98 (insert
|
|
|
99 "\n"
|
|
|
100 "\treturn (gtk_type_to_lisp (&arg));\n"
|
|
|
101 "}\n\n")
|
|
|
102 (push c-func-name func-names))
|
|
|
103 func-names))
|
|
|
104
|
|
|
105 (defun import-widget-accessors (file syms-function-name &rest description)
|
|
|
106 "Import multiple widgets, and emit a suitable vars_of_foo() function for them.\n"
|
|
|
107 (let ((c-mode-common-hook nil)
|
|
|
108 (c-mode-hook nil))
|
|
|
109 (find-file file))
|
|
|
110 (erase-buffer)
|
|
|
111 (let ((c-funcs nil))
|
|
|
112 (while description
|
|
|
113 (setq c-funcs (nconc (define-widget-accessors
|
|
|
114 (pop description) (pop description)
|
|
|
115 (pop description) (pop description)) c-funcs)))
|
|
|
116 (goto-char (point-max))
|
|
|
117 (insert "void " syms-function-name " (void)\n"
|
|
|
118 "{\n\t"
|
|
|
119 (mapconcat (lambda (x)
|
|
|
120 (concat "DEFSUBR (" x ");")) c-funcs "\n\t")
|
|
|
121 "\n}"))
|
|
|
122 (save-buffer))
|
|
|
123
|
|
|
124 ;; Because the new FFI layer imports GTK types lazily, we need to load
|
|
|
125 ;; up all of the gtk types we know about, or we get errors about
|
|
|
126 ;; unknown GTK types later on.
|
|
|
127 (mapatoms (lambda (sym)
|
|
|
128 (if (string-match "gtk-[^-]+-get-type" (symbol-name sym))
|
|
|
129 (funcall sym))))
|
|
|
130
|
|
|
131 (import-widget-accessors
|
|
|
132 "../../src/emacs-widget-accessors.c"
|
|
|
133 "syms_of_widget_accessors "
|
|
|
134
|
|
|
135 'GtkAdjustment "ADJUSTMENT" "adjustment"
|
|
|
136 '((gfloat . lower)
|
|
|
137 (gfloat . upper)
|
|
|
138 (gfloat . value)
|
|
|
139 (gfloat . step_increment)
|
|
|
140 (gfloat . page_increment)
|
|
|
141 (gfloat . page_size))
|
|
|
142
|
|
|
143 'GtkWidget "WIDGET" "widget"
|
|
|
144 '((GtkStyle . style)
|
|
|
145 (GdkWindow . window)
|
|
|
146 (GtkStateType . state)
|
|
|
147 (GtkString . name)
|
|
|
148 (GtkWidget . parent))
|
|
|
149
|
|
|
150 'GtkButton "BUTTON" "button"
|
|
|
151 '((GtkWidget . child)
|
|
|
152 (gboolean . in_button)
|
|
|
153 (gboolean . button_down))
|
|
|
154
|
|
|
155 'GtkCombo "COMBO" "combo"
|
|
|
156 '((GtkWidget . entry)
|
|
|
157 (GtkWidget . button)
|
|
|
158 (GtkWidget . popup)
|
|
|
159 (GtkWidget . popwin)
|
|
|
160 (GtkWidget . list))
|
|
|
161
|
|
|
162 'GtkGammaCurve "GAMMA_CURVE" "gamma-curve"
|
|
|
163 '((GtkWidget . table)
|
|
|
164 (GtkWidget . curve)
|
|
|
165 (gfloat . gamma)
|
|
|
166 (GtkWidget . gamma_dialog)
|
|
|
167 (GtkWidget . gamma_text))
|
|
|
168
|
|
|
169 'GtkCheckMenuItem "CHECK_MENU_ITEM" "check-menu-item"
|
|
|
170 '((gboolean . active))
|
|
|
171
|
|
|
172 'GtkNotebook "NOTEBOOK" "notebook"
|
|
|
173 '((GtkPositionType . tab_pos))
|
|
|
174
|
|
|
175 'GtkText "TEXT" "text"
|
|
|
176 '((GtkAdjustment . hadj)
|
|
|
177 (GtkAdjustment . vadj))
|
|
|
178
|
|
|
179 'GtkFileSelection "FILE_SELECTION" "file-selection"
|
|
|
180 '((GtkWidget . dir_list)
|
|
|
181 (GtkWidget . file_list)
|
|
|
182 (GtkWidget . selection_entry)
|
|
|
183 (GtkWidget . selection_text)
|
|
|
184 (GtkWidget . main_vbox)
|
|
|
185 (GtkWidget . ok_button)
|
|
|
186 (GtkWidget . cancel_button)
|
|
|
187 (GtkWidget . help_button)
|
|
|
188 (GtkWidget . action_area))
|
|
|
189
|
|
|
190 'GtkFontSelectionDialog "FONT_SELECTION_DIALOG" "font-selection-dialog"
|
|
|
191 '((GtkWidget . fontsel)
|
|
|
192 (GtkWidget . main_vbox)
|
|
|
193 (GtkWidget . action_area)
|
|
|
194 (GtkWidget . ok_button)
|
|
|
195 (GtkWidget . apply_button)
|
|
|
196 (GtkWidget . cancel_button))
|
|
|
197
|
|
|
198 'GtkColorSelectionDialog "COLOR_SELECTION_DIALOG" "color-selection-dialog"
|
|
|
199 '((GtkWidget . colorsel)
|
|
|
200 (GtkWidget . main_vbox)
|
|
|
201 (GtkWidget . ok_button)
|
|
|
202 (GtkWidget . reset_button)
|
|
|
203 (GtkWidget . cancel_button)
|
|
|
204 (GtkWidget . help_button))
|
|
|
205
|
|
|
206 'GtkDialog "DIALOG" "dialog"
|
|
|
207 '((GtkWidget . vbox)
|
|
|
208 (GtkWidget . action_area))
|
|
|
209
|
|
|
210 'GtkInputDialog "INPUT_DIALOG" "input-dialog"
|
|
|
211 '((GtkWidget . close_button)
|
|
|
212 (GtkWidget . save_button))
|
|
|
213
|
|
|
214 'GtkPlug "PLUG" "plug"
|
|
|
215 '((GdkWindow . socket_window)
|
|
|
216 (gint . same_app))
|
|
|
217
|
|
|
218 'GtkObject "OBJECT" "object"
|
|
|
219 '((guint . flags)
|
|
|
220 (guint . ref_count))
|
|
|
221
|
|
|
222 'GtkPaned "PANED" "paned"
|
|
|
223 '((GtkWidget . child1)
|
|
|
224 (GtkWidget . child2)
|
|
|
225 (gboolean . child1_resize)
|
|
|
226 (gboolean . child2_resize)
|
|
|
227 (gboolean . child1_shrink)
|
|
|
228 (gboolean . child2_shrink))
|
|
|
229
|
|
|
230 'GtkCList "CLIST" "clist"
|
|
|
231 '((gint . rows)
|
|
|
232 (gint . columns)
|
|
|
233 (GtkAdjustment . hadjustment)
|
|
|
234 (GtkAdjustment . vadjustment)
|
|
|
235 (GtkSortType . sort_type)
|
|
|
236 (gint . focus_row)
|
|
|
237 (gint . sort_column))
|
|
|
238
|
|
|
239 'GtkList "LIST" "list"
|
|
|
240 '((GtkListOfObject . children)
|
|
|
241 (GtkListOfObject . selection))
|
|
|
242
|
|
|
243 'GtkTree "TREE" "tree"
|
|
|
244 '((GtkListOfObject . children)
|
|
|
245 (GtkTree . root_tree)
|
|
|
246 (GtkWidget . tree_owner)
|
|
|
247 (GtkListOfObject . selection))
|
|
|
248
|
|
|
249 'GtkTreeItem "TREE_ITEM" "tree-item"
|
|
|
250 '((GtkWidget . subtree))
|
|
|
251
|
|
|
252 'GtkScrolledWindow "SCROLLED_WINDOW" "scrolled-window"
|
|
|
253 '((GtkWidget . hscrollbar)
|
|
|
254 (GtkWidget . vscrollbar)
|
|
|
255 (gboolean . hscrollbar_visible)
|
|
|
256 (gboolean . vscrollbar_visible))
|
|
|
257
|
|
|
258 )
|
