File: gtk-widget-accessors.el

package info (click to toggle)
xemacs21 21.4.24-9
  • links: PTS
  • area: main
  • in suites: bullseye
  • size: 33,952 kB
  • sloc: ansic: 243,821; lisp: 94,071; cpp: 5,726; sh: 4,406; perl: 1,096; cs: 775; makefile: 761; python: 279; asm: 248; lex: 119; yacc: 95; sed: 22; csh: 9
file content (258 lines) | stat: -rw-r--r-- 7,653 bytes parent folder | download | duplicates (12)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
(require 'gtk-ffi)

(defconst GTK_TYPE_INVALID 0)
(defconst GTK_TYPE_NONE 1)
(defconst GTK_TYPE_CHAR 2)
(defconst GTK_TYPE_UCHAR 3)
(defconst GTK_TYPE_BOOL 4)
(defconst GTK_TYPE_INT 5)
(defconst GTK_TYPE_UINT 6)
(defconst GTK_TYPE_LONG 7)
(defconst GTK_TYPE_ULONG 8)
(defconst GTK_TYPE_FLOAT 9)
(defconst GTK_TYPE_DOUBLE 10)
(defconst GTK_TYPE_STRING 11)
(defconst GTK_TYPE_ENUM 12)
(defconst GTK_TYPE_FLAGS 13)
(defconst GTK_TYPE_BOXED 14)
(defconst GTK_TYPE_POINTER 15)
(defconst GTK_TYPE_SIGNAL 16)
(defconst GTK_TYPE_ARGS 17)
(defconst GTK_TYPE_CALLBACK 18)
(defconst GTK_TYPE_C_CALLBACK 19)
(defconst GTK_TYPE_FOREIGN 20)
(defconst GTK_TYPE_OBJECT 21)

(defconst gtk-value-accessor-names
  '("INVALID" "NONE" "CHAR" "UCHAR" "BOOL" "INT" "UINT" "LONG" "ULONG" "FLOAT" "DOUBLE"
    "STRING" "ENUM" "FLAGS" "BOXED" "POINTER" "SIGNAL" "ARGS" "CALLBACK" "C_CALLBACK"
    "FOREIGN" "OBJECT"))

(defun define-widget-accessors (gtk-class
				wrapper
				prefix args)
  "Output stub C code to access parts of a widget from lisp.
GTK-CLASS is the GTK class to grant access to.
WRAPPER is a fragment to construct GTK C macros for typechecking/etc. (ie: WIDGET)
ARGS is a list of (type . name) cons cells.
Defines a whole slew of functions to access & set the slots in the
structure."
  (set-buffer (get-buffer-create "emacs-widget-accessors.c"))
  (goto-char (point-max))
  (let ((arg)
	(base-arg-type nil)
	(lisp-func-name nil)
	(c-func-name nil)
	(func-names nil))
    (setq gtk-class (symbol-name gtk-class)
	  wrapper (upcase wrapper))
    (while (setq arg (pop args))
      (setq lisp-func-name (format "gtk-%s-%s" prefix (cdr arg))
	    lisp-func-name (replace-in-string lisp-func-name "_" "-")
	    c-func-name (concat "F" (replace-in-string lisp-func-name "-" "_")))
      (insert
       "DEFUN (\"" lisp-func-name "\", " c-func-name ", 1, 1, 0, /*\n"
       "Access the `" (symbol-name (cdr arg)) "' slot of OBJ, a " gtk-class " object.\n"
       "*/\n"
       "\t(obj))\n"
       "{\n"
       (format "\t%s *the_obj = NULL;\n" gtk-class)
       "\tGtkArg arg;\n"
       "\n"
       "\tCHECK_GTK_OBJECT (obj);\n"
       "\n"
       (format "\tif (!GTK_IS_%s (XGTK_OBJECT (obj)->object))\n" wrapper)
       "\t{\n"
       (format "\t\tsignal_simple_error (\"Object is not a %s\", obj);\n" gtk-class)
       "\t};\n"
       "\n"
       (format "\tthe_obj = GTK_%s (XGTK_OBJECT (obj)->object);\n" wrapper)

       (format "\targ.type = gtk_type_from_name (\"%s\");\n" (symbol-name (car arg))))
;       (format "\targ.type = GTK_TYPE_%s;\n" (or
;					       (nth (gtk-fundamental-type (car arg))
;						    gtk-value-accessor-names)
;					       (case (car arg)
;						 (GtkListOfString "STRING_LIST")
;						 (GtkListOfObject "OBJECT_LIST")
;						 (otherwise
;						  "POINTER")))))

      (setq base-arg-type (gtk-fundamental-type (car arg)))
      (cond
       ((= base-arg-type GTK_TYPE_OBJECT)
	(insert
	 (format "\tGTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->%s);"
		 (cdr arg))))
       ((or (= base-arg-type GTK_TYPE_POINTER)
	    (= base-arg-type GTK_TYPE_BOXED))
	(insert
	 (format "\tGTK_VALUE_%s (arg) = (void *)the_obj->%s;"
		 (nth (gtk-fundamental-type (car arg)) gtk-value-accessor-names)
		 (cdr arg))))
       (t
	(insert
	 (format "\tGTK_VALUE_%s (arg) = the_obj->%s;"
		 (or (nth (gtk-fundamental-type (car arg)) gtk-value-accessor-names) "POINTER")
		 (cdr arg)))))
      (insert
       "\n"
       "\treturn (gtk_type_to_lisp (&arg));\n"
       "}\n\n")
      (push c-func-name func-names))
    func-names))

(defun import-widget-accessors (file syms-function-name &rest description)
  "Import multiple widgets, and emit a suitable vars_of_foo() function for them.\n"
  (let ((c-mode-common-hook nil)
	(c-mode-hook nil))
    (find-file file))
  (erase-buffer)
  (let ((c-funcs nil))
    (while description
      (setq c-funcs (nconc (define-widget-accessors
			     (pop description) (pop description)
			     (pop description) (pop description)) c-funcs)))
    (goto-char (point-max))
    (insert "void " syms-function-name " (void)\n"
	    "{\n\t"
	    (mapconcat (lambda (x)
			 (concat "DEFSUBR (" x ");")) c-funcs "\n\t")
	    "\n}"))
  (save-buffer))

;; Because the new FFI layer imports GTK types lazily, we need to load
;; up all of the gtk types we know about, or we get errors about
;; unknown GTK types later on.
(mapatoms (lambda (sym)
	    (if (string-match "gtk-[^-]+-get-type" (symbol-name sym))
		(funcall sym))))

(import-widget-accessors
 "../../src/emacs-widget-accessors.c"
 "syms_of_widget_accessors "

 'GtkAdjustment "ADJUSTMENT" "adjustment"
 '((gfloat . lower)
   (gfloat . upper)
   (gfloat . value)
   (gfloat . step_increment)
   (gfloat . page_increment)
   (gfloat . page_size))

 'GtkWidget "WIDGET" "widget"
 '((GtkStyle     . style)
   (GdkWindow    . window)
   (GtkStateType . state)
   (GtkString    . name)
   (GtkWidget    . parent))

 'GtkButton "BUTTON" "button"
 '((GtkWidget  . child)
   (gboolean   . in_button)
   (gboolean   . button_down))

 'GtkCombo "COMBO" "combo"
 '((GtkWidget  . entry)
   (GtkWidget  . button)
   (GtkWidget  . popup)
   (GtkWidget  . popwin)
   (GtkWidget  . list))

 'GtkGammaCurve "GAMMA_CURVE" "gamma-curve"
 '((GtkWidget  . table)
   (GtkWidget  . curve)
   (gfloat      . gamma)
   (GtkWidget  . gamma_dialog)
   (GtkWidget  . gamma_text))

 'GtkCheckMenuItem "CHECK_MENU_ITEM" "check-menu-item"
 '((gboolean   . active))

 'GtkNotebook "NOTEBOOK" "notebook"
 '((GtkPositionType . tab_pos))

 'GtkText "TEXT" "text"
 '((GtkAdjustment . hadj)
   (GtkAdjustment . vadj))

 'GtkFileSelection "FILE_SELECTION" "file-selection"
 '((GtkWidget . dir_list)
   (GtkWidget . file_list)
   (GtkWidget . selection_entry)
   (GtkWidget . selection_text)
   (GtkWidget . main_vbox)
   (GtkWidget . ok_button)
   (GtkWidget . cancel_button)
   (GtkWidget . help_button)
   (GtkWidget . action_area))

 'GtkFontSelectionDialog "FONT_SELECTION_DIALOG" "font-selection-dialog"
 '((GtkWidget . fontsel)
   (GtkWidget . main_vbox)
   (GtkWidget . action_area)
   (GtkWidget . ok_button)
   (GtkWidget . apply_button)
   (GtkWidget . cancel_button))

 'GtkColorSelectionDialog "COLOR_SELECTION_DIALOG" "color-selection-dialog"
 '((GtkWidget . colorsel)
   (GtkWidget . main_vbox)
   (GtkWidget . ok_button)
   (GtkWidget . reset_button)
   (GtkWidget . cancel_button)
   (GtkWidget . help_button))

 'GtkDialog "DIALOG" "dialog"
 '((GtkWidget . vbox)
   (GtkWidget . action_area))

 'GtkInputDialog "INPUT_DIALOG" "input-dialog"
 '((GtkWidget . close_button)
   (GtkWidget . save_button))

 'GtkPlug "PLUG" "plug"
 '((GdkWindow . socket_window)
   (gint      . same_app))

 'GtkObject "OBJECT" "object"
 '((guint     . flags)
   (guint     . ref_count))

 'GtkPaned "PANED" "paned"
 '((GtkWidget . child1)
   (GtkWidget . child2)
   (gboolean  . child1_resize)
   (gboolean  . child2_resize)
   (gboolean  . child1_shrink)
   (gboolean  . child2_shrink))

 'GtkCList "CLIST" "clist"
 '((gint . rows)
   (gint . columns)
   (GtkAdjustment . hadjustment)
   (GtkAdjustment . vadjustment)
   (GtkSortType   . sort_type)
   (gint . focus_row)
   (gint . sort_column))

 'GtkList "LIST" "list"
 '((GtkListOfObject . children)
   (GtkListOfObject . selection))

 'GtkTree "TREE" "tree"
 '((GtkListOfObject . children)
   (GtkTree         . root_tree)
   (GtkWidget       . tree_owner)
   (GtkListOfObject . selection))

 'GtkTreeItem "TREE_ITEM" "tree-item"
 '((GtkWidget       . subtree))

 'GtkScrolledWindow "SCROLLED_WINDOW" "scrolled-window"
 '((GtkWidget . hscrollbar)
   (GtkWidget . vscrollbar)
   (gboolean  . hscrollbar_visible)
   (gboolean  . vscrollbar_visible))

 )