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