Mercurial > hg > xemacs-beta
comparison lisp/gtk-widget-accessors.el @ 462:0784d089fdc9 r21-2-46
Import from CVS: tag r21-2-46
author | cvs |
---|---|
date | Mon, 13 Aug 2007 11:44:37 +0200 |
parents | |
children | 7039e6323819 |
comparison
equal
deleted
inserted
replaced
461:120ed4009e51 | 462:0784d089fdc9 |
---|---|
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 ) |