1 /* -*- tab-width:4; -*- */
2 /*
3 * GTK binding for QSCHEME
4 */
5
6 #include "s.h"
7 #include "vm2.h"
8 #include "stack.h"
9 #include "sgtk.h"
10
11
12 /*** Debugging for object deallocation */
13 #ifdef DEBUG_SWEEP
SWEEPING(SOBJ x)14 void SWEEPING(SOBJ x)
15 {
16 scm_puts("; SWEEPING "); scm_cprint(x);
17 }
18 #endif
19
20 /*-- new object types */
21 /*** GDK types */
22 int SOBJ_T_GdkFont;
23 int SOBJ_T_GdkColor;
24 int SOBJ_T_GdkEvent;
25 int SOBJ_T_GdkWindow;
26 int SOBJ_T_GdkGC;
27 int SOBJ_T_GdkVisual;
28 int SOBJ_T_GdkColormap;
29 int SOBJ_T_GdkDragContext;
30 int SOBJ_T_GdkAtom;
31 int SOBJ_T_GdkCursor;
32 int SOBJ_T_GtkCTreeNode;
33
34 /*** GTK Types */
35 int SOBJ_T_GtkObject; /* the gtk objects */
36 int SOBJ_T_GtkAccelGroup; /* the accell group */
37 int SOBJ_T_GtkStyleHelper;
38 int SOBJ_T_GtkStyle;
39 int SOBJ_T_GtkSelectionData;
40
41 #ifdef LIBGLADE_SUPPORT
42 int SOBJ_T_GLADE_XML; /* glade xml */
43 #endif /* LIBGLADE_SUPPORT */
44
45
46 /* Hash to keep track of objects: objects are hidden from GC behind a
47 * pointer.
48 */
49 SOBJ sgtk_obj_cache; /* keep track of alive objects */
50
sgtk_obj_cache_add(gpointer gtkobj,SOBJ scmobj)51 void sgtk_obj_cache_add(gpointer gtkobj, SOBJ scmobj)
52 {
53 #ifdef DEBUG_ALIVE
54 scm_puts("DEBUG: obj_cache_add ("); scm_putx(gtkobj);
55 scm_puts(","); scm_cdisplay(scmobj); scm_puts(")\n");
56 #endif
57 scm_hash_set(sgtk_obj_cache, scm_mkpointer(gtkobj), scm_mkpointer(scmobj));
58 }
59
sgtk_obj_cache_get(gpointer gtkobj)60 static SOBJ sgtk_obj_cache_get(gpointer gtkobj)
61 {
62 SOBJ res;
63 res = scm_hash_ref(sgtk_obj_cache, scm_mkpointer(gtkobj));
64 if (res != scm_undefined)
65 res = SCM_POINTER(res);
66
67 #ifdef DEBUG_ALIVE
68 scm_puts("DEBUG: obj_cache_get ("); scm_putx(gtkobj); scm_puts(")->");
69 scm_cprint(res);
70 #endif
71 return(res);
72 }
73
sgtk_obj_cache_remove(gpointer gtkobj)74 void sgtk_obj_cache_remove(gpointer gtkobj)
75 {
76 #ifdef DEBUG_ALIVE
77 scm_puts("DEBUG: obj_cache_remove ("); scm_putx(gtkobj); scm_puts(")\n");
78 #endif
79 scm_hash_remove(sgtk_obj_cache, scm_mkpointer(gtkobj));
80 }
81
82 /*** GC protection scheme
83 * ALL alive gtk objects are recenced in this hash table.
84 * The key is a pointer to a gtk object
85 * The value associated is the pointer to the scheme object
86 */
87
88 /*** Func hash: Keeps track of functions which are not referenced from
89 * the Scheme side, like callbacks functions.
90 *
91 * The GC will keep this functions because they are referenced here.
92 */
93
94 SOBJ sgtk_func_hash; /* keep track of callbacks functions */
95
sgtk_func_add(gpointer gtkobj,SOBJ scmobj)96 void sgtk_func_add(gpointer gtkobj, SOBJ scmobj)
97 {
98 #ifdef DEBUG_ALIVE
99 scm_puts("DEBUG: func_add ("); scm_putx(gtkobj);
100 scm_puts(","); scm_cdisplay(scmobj); scm_puts(")\n");
101 #endif
102 scm_hash_set(sgtk_func_hash, scm_mkpointer(gtkobj), scmobj);
103 }
104
sgtk_func_get(gpointer gtkobj)105 static SOBJ sgtk_func_get(gpointer gtkobj)
106 {
107 #ifdef DEBUG_ALIVE
108 scm_puts("DEBUG: func_get ("); scm_putx(gtkobj); scm_puts(")\n");
109 #endif
110 return(scm_hash_ref(sgtk_func_hash, scm_mkpointer(gtkobj)));
111 }
112
sgtk_func_remove(gpointer gtkobj)113 static void sgtk_func_remove(gpointer gtkobj)
114 {
115 #ifdef DEBUG_ALIVE
116 scm_puts("DEBUG: func_remove ("); scm_putx(gtkobj); scm_puts(")\n");
117 #endif
118 scm_hash_remove(sgtk_func_hash, scm_mkpointer(gtkobj));
119 }
120
121
122 /****************************************************************
123 * utilities
124 ****************************************************************/
125
126 /*** utilities ***/
127
scm_fetch_aux(SOBJ x)128 static void *scm_fetch_aux(SOBJ x)
129 {
130 return(SCM_AUX(x));
131 }
132
sgtk_aux_compare(SOBJ x,SOBJ y)133 SOBJ sgtk_aux_compare(SOBJ x, SOBJ y)
134 {
135 return(SCM_MKBOOL(SCM_AUX(x) == SCM_AUX(y)));
136 }
137
138 /*** Enum */
139
140 /*** Determine the enum value given the type and the type member */
enum_getv(GtkType type,SOBJ obj)141 static int enum_getv(GtkType type, SOBJ obj)
142 {
143 char *member;
144 GtkEnumValue *info;
145
146 if (SCM_INUMP(obj)) return SCM_INUM(obj);
147 if (SCM_NUMBERP(obj)) return scm_number2long(obj);
148
149 if ( (member = scm_getstr(obj)) == NULL)
150 SCM_ERR("enum values must be string or int", obj);
151
152 if ( (info = gtk_type_enum_find_value(type, member)) == NULL)
153 return(-1);
154
155 return(info->value);
156 }
157
158 /*** func called by wrappers */
sgtk_enumget(char * typename,SOBJ member)159 int sgtk_enumget(char *typename, SOBJ member)
160 {
161 GtkType type;
162 int value;
163
164 if ((type = gtk_type_from_name(typename)) == 0)
165 SCM_ERR("unknown enum type", scm_mkstring(typename));
166
167 if ((value = enum_getv(type, member)) == -1)
168 SCM_ERR("unknow enum member", scm_cons(scm_mkstring(typename), member));
169
170 return(value);
171 }
172
173 /*E* (gtk-enum-get TYPE MEMBER) => INT */
174 /*D* Returns the value of the MEMBER of enum TYPE. MEMBER is a string
175 and TYPE is either an INT or a STRING */
176
sgtk_enum_get(SOBJ type,SOBJ member)177 SOBJ sgtk_enum_get(SOBJ type, SOBJ member)
178 {
179 char *typename;
180 if (SCM_INUMP(member) || SCM_NUMBERP(member)) return(member);
181 if ((typename = scm_getstr(type)) == NULL) SCM_ERR("bad type name", type);
182 return(SCM_MKINUM(sgtk_enumget(typename, member)));
183 }
184
flag_getv(GtkType flag_type,SOBJ obj)185 static int flag_getv(GtkType flag_type, SOBJ obj)
186 {
187 int value;
188 char *member;
189 GtkFlagValue *info;
190
191 if (SCM_INUMP(obj)) return(SCM_INUM(obj));
192 if (SCM_NUMBERP(obj)) return(scm_number2long(obj));
193
194 if ( (member = scm_getstr(obj)) != NULL) {
195 if ((info = gtk_type_flags_find_value(flag_type, member)) == NULL)
196 SCM_ERR("bad flag member", obj);
197
198 return(info->value);
199 }
200 if (!SCM_PAIRP(obj))
201 SCM_ERR("flag_getv: bad int|string|list", obj);
202
203 value = 0;
204 while(obj) {
205 if (!SCM_PAIRP(obj)) SCM_ERR("flag_getv: bad list", obj);
206 value |= flag_getv(flag_type, SCM_CAR(obj));
207 obj = SCM_CDR(obj);
208 }
209 return(value);
210 }
211
212 /*** func called by wrappers */
sgtk_flagsget(char * typename,SOBJ member)213 int sgtk_flagsget(char *typename, SOBJ member)
214 {
215 GtkType type;
216 int value;
217
218 if ((type = gtk_type_from_name(typename)) == 0)
219 SCM_ERR("unknown flag type", scm_mkstring(typename));
220
221 if ((value = flag_getv(type, member)) == -1)
222 SCM_ERR("unknow flag member", scm_cons(scm_mkstring(typename), member));
223
224 return(value);
225 }
226
227 /*E* (sgtk-flags-get TYPE MEMBER) => INT */
228 /*D* Returns the value of the MEMBER of flags TYPE. MEMBER is a string
229 and TYPE is either an INT or a STRING */
230
sgtk_flags_get(SOBJ type,SOBJ member)231 SOBJ sgtk_flags_get(SOBJ type, SOBJ member)
232 {
233 char *typename;
234 if (SCM_INUMP(member) || SCM_NUMBERP(member)) return(member);
235 if ((typename = scm_getstr(type)) == NULL) SCM_ERR("bad type name", type);
236 return(SCM_MKINUM(sgtk_flagsget(typename, member)));
237 }
238
239 /****************************************************************
240 * GDK
241 ****************************************************************/
242
243 /*** GdkFont ***/
244
sgdk_Font_new(GdkFont * obj)245 SOBJ sgdk_Font_new(GdkFont *obj)
246 {
247 SOBJ new = scm_newcell(SOBJ_T_GdkFont);
248 SGDK_FONT(new) = obj;
249 gdk_font_ref(obj);
250 sgtk_obj_cache_add(obj, new);
251 return(new);
252 }
253
sgdk_Font_sweep(SOBJ x)254 static void sgdk_Font_sweep(SOBJ x)
255 {
256 SWEEPING(x);
257 gdk_font_unref(SCM_AUX(x));
258 sgtk_obj_cache_remove(SCM_AUX(x));
259 }
260
sgdk_Font_compare(SOBJ x,SOBJ y)261 static SOBJ sgdk_Font_compare(SOBJ x, SOBJ y)
262 {
263 return(SCM_MKBOOL(gdk_font_equal(SGDK_FONT(x), SGDK_FONT(y))));
264 }
265
GdkFont2scm(int type,void * p)266 static SOBJ GdkFont2scm(int type, void *p)
267 {
268 return(sgdk_Font_new(p));
269 }
270
sgdk_get_Font(SOBJ obj)271 void *sgdk_get_Font(SOBJ obj)
272 {
273 return(obj ? SGDK_FONT(obj) : NULL);
274 }
275
276 static SOBJ_TYPE_DESCR sgdk_Font_type_descr = {
277 0,
278 "GdkFont",
279 NULL, sgdk_Font_sweep, /* mark / sweep */
280 NULL, NULL, /* print */
281 NULL, NULL, NULL, NULL, /* parse */
282 sgdk_Font_compare, /* compare */
283 GdkFont2scm, sgdk_get_Font /* get / set */
284 };
285
286 /*** GdkColor ***/
287
sgdk_Color_new(GdkColor * obj)288 SOBJ sgdk_Color_new(GdkColor *obj)
289 {
290 SOBJ new = scm_newcell(SOBJ_T_GdkColor);
291 SGDK_COLOR(new) = scm_must_alloc(sizeof(GdkColor));
292 *SGDK_COLOR(new) = *obj;
293 return(new);
294 }
295
sgdk_Color_sweep(SOBJ obj)296 static void sgdk_Color_sweep(SOBJ obj)
297 {
298 SWEEPING(obj);
299 if (SGDK_COLOR(obj)) {
300 scm_free(SGDK_COLOR(obj));
301 SGDK_COLOR(obj) = NULL;
302 }
303 }
304
sgdk_color_print(SOBJ x,PORT * p)305 static void sgdk_color_print(SOBJ x, PORT *p)
306 {
307 char buf[128];
308 GdkColor *col = SGDK_COLOR(x);
309 sprintf(buf, "#<color index=%d rgb=%d %d %d>",
310 col->pixel, col->red, col->green, col->blue);
311 port_puts(p, buf);
312 }
313
GdkColor2scm(int type,void * p)314 static SOBJ GdkColor2scm(int type, void *p)
315 {
316 return(sgdk_Color_new(p));
317 }
318
sgdk_get_Color(SOBJ obj)319 void *sgdk_get_Color(SOBJ obj)
320 {
321 return(obj ? SGDK_COLOR(obj) : NULL);
322 }
323
324 static SOBJ_TYPE_DESCR sgdk_Color_type_descr = {
325 0,
326 "GdkColor",
327 NULL, sgdk_Color_sweep, /* mark / sweep */
328 sgdk_color_print, sgdk_color_print, /* print */
329 NULL, NULL, NULL, NULL, /* parse */
330 NULL, /* compare */
331 GdkColor2scm, sgdk_get_Color /* get / set */
332 };
333
334
335 /*** GdkWindow ***/
sgdk_Window_new(GdkWindow * win)336 SOBJ sgdk_Window_new(GdkWindow *win)
337 {
338 SOBJ new = scm_newcell(SOBJ_T_GdkWindow);
339 /* g_print("sgdk_Window_new: window %p\n", win); */
340 SGDK_WINDOW(new) = win;
341 /*sgtk_obj_cache_add(win, new); */
342 return(new);
343 }
344
sgdk_Window_sweep(SOBJ x)345 static void sgdk_Window_sweep(SOBJ x)
346 {
347 GdkWindow *w = SGDK_WINDOW(x);
348
349 SWEEPING(x);
350 /*
351 if (gdk_window_get_type(w) == GDK_WINDOW_PIXMAP)
352 gdk_pixmap_unref(w);
353 else
354 gdk_window_unref(w);
355 */
356 /* sgtk_obj_cache_remove(w); */
357 }
358
GdkWindow2scm(int type,void * p)359 static SOBJ GdkWindow2scm(int type, void *p)
360 {
361 /* SOBJ ret;
362 if ((ret = sgtk_obj_cache_get(p)) != scm_undefined) {
363 return(ret);
364 }
365 */
366 return(sgdk_Window_new(p));
367 }
368
sgdk_get_Window(SOBJ obj)369 void *sgdk_get_Window(SOBJ obj)
370 {
371 return(obj == NULL ? NULL : SGDK_WINDOW(obj));
372 }
373
374
375
376 static SOBJ_TYPE_DESCR sgdk_Window_type_descr = {
377 0,
378 "GdkWindow",
379 NULL, sgdk_Window_sweep, /* mark / sweep */
380 NULL, NULL, /* print */
381 NULL, NULL, NULL, NULL, /* parse */
382 sgtk_aux_compare, /* compare */
383 GdkWindow2scm, sgdk_get_Window /* get / set */
384 };
385
386
387 /*** GdkGC ***/
sgdk_GC_new(GdkGC * gc)388 SOBJ sgdk_GC_new(GdkGC *gc)
389 {
390 SOBJ new = scm_newcell(SOBJ_T_GdkGC);
391 SGDK_GC(new) = gc;
392 gdk_gc_ref(gc);
393 sgtk_obj_cache_add(gc, new);
394 return(new);
395 }
396
sgdk_GC_sweep(SOBJ x)397 static void sgdk_GC_sweep(SOBJ x)
398 {
399 SWEEPING(x);
400 gdk_gc_unref(SGDK_GC(x));
401 sgtk_obj_cache_remove(SGDK_GC(x));
402 }
403
GdkGC2scm(int type,void * p)404 static SOBJ GdkGC2scm(int type, void *p)
405 {
406 return(sgdk_GC_new(p));
407 }
408
sgdk_get_GC(SOBJ obj)409 void *sgdk_get_GC(SOBJ obj)
410 {
411 return(SGDK_GC(obj));
412 }
413
414 static SOBJ_TYPE_DESCR sgdk_GC_type_descr = {
415 0,
416 "GdkGC",
417 NULL, sgdk_GC_sweep, /* mark / sweep */
418 NULL, NULL, /* print */
419 NULL, NULL, NULL, NULL, /* parse */
420 sgtk_aux_compare, /* compare */
421 GdkGC2scm, sgdk_get_GC /* get / set */
422 };
423
424 /*** GdkVisual ***/
sgdk_Visual_new(GdkVisual * gc)425 SOBJ sgdk_Visual_new(GdkVisual *gc)
426 {
427 SOBJ new = scm_newcell(SOBJ_T_GdkVisual);
428 SGDK_VISUAL(new) = gc;
429 gdk_visual_ref(gc);
430 sgtk_obj_cache_add(gc, new);
431 return(new);
432 }
433
sgdk_Visual_sweep(SOBJ x)434 static void sgdk_Visual_sweep(SOBJ x)
435 {
436 SWEEPING(x);
437 gdk_visual_unref(SGDK_VISUAL(x));
438 sgtk_obj_cache_remove(SGDK_VISUAL(x));
439 }
440
GdkVisual2scm(int type,void * p)441 static SOBJ GdkVisual2scm(int type, void *p)
442 {
443 return(sgdk_Visual_new(p));
444 }
445
sgdk_get_Visual(SOBJ obj)446 void *sgdk_get_Visual(SOBJ obj)
447 {
448 return(SGDK_VISUAL(obj));
449 }
450
451 static SOBJ_TYPE_DESCR sgdk_Visual_type_descr = {
452 0,
453 "GdkVisual",
454 NULL, sgdk_Visual_sweep, /* mark / sweep */
455 NULL, NULL, /* print */
456 NULL, NULL, NULL, NULL, /* parse */
457 sgtk_aux_compare, /* compare */
458 GdkVisual2scm, sgdk_get_Visual /* get / set */
459 };
460
461 /*** GdkColorMap ***/
sgdk_Colormap_new(GdkColormap * obj)462 SOBJ sgdk_Colormap_new(GdkColormap *obj)
463 {
464 SOBJ new = scm_newcell(SOBJ_T_GdkColormap);
465 SGDK_COLORMAP(new) = obj;
466 gdk_colormap_ref(obj);
467 sgtk_obj_cache_add(obj, new);
468 return(new);
469 }
470
sgdk_Colormap_sweep(SOBJ x)471 static void sgdk_Colormap_sweep(SOBJ x)
472 {
473 SWEEPING(x);
474 gdk_colormap_unref(SGDK_COLORMAP(x));
475 sgtk_obj_cache_remove(SGDK_COLORMAP(x));
476 }
477
GdkColormap2scm(int type,void * p)478 static SOBJ GdkColormap2scm(int type, void *p)
479 {
480 return(sgdk_Colormap_new(p));
481 }
482
sgdk_get_Colormap(SOBJ obj)483 void *sgdk_get_Colormap(SOBJ obj)
484 {
485 return(SGDK_COLORMAP(obj));
486 }
487
488 static SOBJ_TYPE_DESCR sgdk_Colormap_type_descr = {
489 0,
490 "GdkColormap",
491 NULL, sgdk_Colormap_sweep, /* mark / sweep */
492 NULL, NULL, /* print */
493 NULL, NULL, NULL, NULL, /* parse */
494 sgtk_aux_compare, /* compare */
495 GdkColormap2scm, sgdk_get_Colormap /* get / set */
496 };
497
498 /*** GdkDragContext ***/
sgdk_DragContext_new(GdkDragContext * obj)499 SOBJ sgdk_DragContext_new(GdkDragContext *obj)
500 {
501 SOBJ new = scm_newcell(SOBJ_T_GdkDragContext);
502 SGDK_DRAGCONTEXT(new) = obj;
503 gdk_drag_context_ref(obj);
504 sgtk_obj_cache_add(obj, new);
505 return(new);
506 }
507
sgdk_DragContext_sweep(SOBJ x)508 static void sgdk_DragContext_sweep(SOBJ x)
509 {
510 SWEEPING(x);
511 gdk_drag_context_unref(SGDK_DRAGCONTEXT(x));
512 sgtk_obj_cache_remove(SGDK_DRAGCONTEXT(x));
513 }
514
GdkDragContext2scm(int type,void * p)515 static SOBJ GdkDragContext2scm(int type, void *p)
516 {
517 return(sgdk_DragContext_new(p));
518 }
519
sgdk_get_DragContext(SOBJ obj)520 void *sgdk_get_DragContext(SOBJ obj)
521 {
522 return(SGDK_DRAGCONTEXT(obj));
523 }
524
525 static SOBJ_TYPE_DESCR sgdk_DragContext_type_descr = {
526 0,
527 "GdkDragContext",
528 NULL, sgdk_DragContext_sweep, /* mark / sweep */
529 NULL, NULL, /* print */
530 NULL, NULL, NULL, NULL, /* parse */
531 sgtk_aux_compare, /* compare */
532 GdkDragContext2scm, sgdk_get_DragContext /* get / set */
533 };
534
535 /*** GdkAtom ***/
sgdk_Atom_new(GdkAtom obj)536 SOBJ sgdk_Atom_new(GdkAtom obj)
537 {
538 SOBJ new = scm_newcell(SOBJ_T_GdkAtom);
539 SGDK_ATOM_NAME(new) = NULL;
540 SGDK_ATOM_ATOM(new) = obj;
541 return(new);
542 }
543
sgdk_Atom_sweep(SOBJ obj)544 static void sgdk_Atom_sweep(SOBJ obj)
545 {
546 SWEEPING(obj);
547 if (SGDK_ATOM_NAME(obj)) {
548 scm_free(SGDK_ATOM_NAME(obj)); SGDK_ATOM_NAME(obj) = NULL;
549 }
550 }
551
GdkAtom2scm(int type,GdkAtom atom)552 static SOBJ GdkAtom2scm(int type, GdkAtom atom)
553 {
554 return(sgdk_Atom_new(atom));
555 }
556
sgdk_get_Atom(SOBJ obj)557 static GdkAtom sgdk_get_Atom(SOBJ obj)
558 {
559 return( SGDK_ATOM_ATOM(obj) );
560 }
561
562 static SOBJ_TYPE_DESCR sgdk_Atom_type_descr = {
563 0,
564 "GdkAtom",
565 NULL, sgdk_Atom_sweep, /* mark / sweep */
566 NULL, NULL, /* print */
567 NULL, NULL, NULL, NULL, /* parse */
568 NULL, /* compare */
569 (void*)GdkAtom2scm, (void*)sgdk_get_Atom /* get / set */
570 };
571
572 /*** GdkCursor ***/
sgdk_Cursor_new(GdkCursor * obj)573 SOBJ sgdk_Cursor_new(GdkCursor *obj)
574 {
575 SOBJ new = scm_newcell(SOBJ_T_GdkCursor);
576 SGDK_CURSOR(new) = obj;
577 sgtk_obj_cache_add(obj, new);
578 return(new);
579 }
580
sgdk_Cursor_sweep(SOBJ x)581 static void sgdk_Cursor_sweep(SOBJ x)
582 {
583 SWEEPING(x);
584 gdk_cursor_destroy(SGDK_CURSOR(x));
585 sgtk_obj_cache_remove(SGDK_CURSOR(x));
586 }
587
GdkCursor2scm(int type,void * p)588 static SOBJ GdkCursor2scm(int type, void *p)
589 {
590 return(sgdk_Cursor_new(p));
591 }
592
sgdk_get_Cursor(SOBJ obj)593 void *sgdk_get_Cursor(SOBJ obj)
594 {
595 return(SGDK_CURSOR(obj));
596 }
597
598 static SOBJ_TYPE_DESCR sgdk_Cursor_type_descr = {
599 0,
600 "GdkCursor",
601 NULL, sgdk_Cursor_sweep, /* mark / sweep */
602 NULL, NULL, /* print */
603 NULL, NULL, NULL, NULL, /* parse */
604 sgtk_aux_compare, /* compare */
605 GdkCursor2scm, sgdk_get_Cursor /* get / set */
606 };
607
608 /*** GdkEvent ***/
sgdk_Event_new(GdkEvent * obj)609 SOBJ sgdk_Event_new(GdkEvent *obj)
610 {
611 SOBJ new = scm_newcell(SOBJ_T_GdkEvent);
612 SGDK_EVENT(new) = scm_must_alloc(sizeof(GdkEvent));
613 *(SGDK_EVENT(new)) = *obj;
614 /* sgtk_obj_cache_add(obj, new); */
615 return(new);
616 }
617
sgdk_Event_sweep(SOBJ x)618 static void sgdk_Event_sweep(SOBJ x)
619 {
620 SWEEPING(x);
621 scm_free(SGDK_EVENT(x));
622 /* sgtk_obj_cache_remove(SGDK_EVENT(x)); */
623 }
624
GdkEvent2scm(int type,void * p)625 static SOBJ GdkEvent2scm(int type, void *p)
626 {
627 return(sgdk_Event_new(p));
628 }
629
sgdk_get_Event(SOBJ obj)630 void *sgdk_get_Event(SOBJ obj)
631 {
632 return(SGDK_EVENT(obj));
633 }
634
635 static SOBJ_TYPE_DESCR sgdk_Event_type_descr = {
636 0,
637 "GdkEvent",
638 NULL, sgdk_Event_sweep, /* mark / sweep */
639 NULL, NULL, /* print */
640 NULL, NULL, NULL, NULL, /* parse */
641 NULL, /* compare */
642 GdkEvent2scm, sgdk_get_Event /* get / set */
643 };
644
645
646 /****************************************************************
647 * GTK
648 ****************************************************************/
649
650 /*** GtkObject ***/
sgtk_object_new(GtkObject * o)651 SOBJ sgtk_object_new(GtkObject *o)
652 {
653 SOBJ new = scm_newcell(SOBJ_T_GtkObject);
654 SGTK_OBJECT(new) = o;
655 gtk_object_ref(o);
656 sgtk_obj_cache_add(o, new);
657 return(new);
658 }
659
sgtk_Object_sweep(SOBJ x)660 static void sgtk_Object_sweep(SOBJ x)
661 {
662 SWEEPING(x);
663 if (SGTK_OBJECT(x)) {
664 gtk_object_unref(SGTK_OBJECT(x));
665 sgtk_obj_cache_remove(SGTK_OBJECT(x));
666 SGTK_OBJECT(x) = NULL;
667 }
668 }
669
sgtk_Object_print(SOBJ x,PORT * p)670 static void sgtk_Object_print(SOBJ x, PORT *p)
671 {
672 char buf[100];
673 sprintf(buf, "#<GtkObject of type %s at %p>",
674 gtk_type_name(GTK_OBJECT_TYPE(SGTK_OBJECT(x))),
675 SGTK_OBJECT(x));
676 port_puts(p, buf);
677 }
678
sgtk_Object2obj(int type,void * p)679 static SOBJ sgtk_Object2obj(int type, void *p)
680 {
681 return(sgtk_object_new(p));
682 }
683
sgtk_get_Object(SOBJ obj)684 void *sgtk_get_Object(SOBJ obj)
685 {
686 return( (obj != NULL) ? SGTK_OBJECT(obj) : NULL);
687 }
688
689 static SOBJ_TYPE_DESCR sgtk_Object_type_descr = {
690 0,
691 "GtkObject",
692 NULL, sgtk_Object_sweep,
693 sgtk_Object_print, sgtk_Object_print,
694 NULL, NULL, NULL, NULL,
695 sgtk_aux_compare,
696 sgtk_Object2obj, /* get */
697 sgtk_get_Object /* set */
698 };
699
700 /*** GtkAccelGroup type ***/
701
sgtk_AccelGroup_new(GtkAccelGroup * obj)702 SOBJ sgtk_AccelGroup_new(GtkAccelGroup *obj)
703 {
704 SOBJ new = scm_newcell(SOBJ_T_GtkAccelGroup);
705 SGTK_ACCELGROUP(new) = obj;
706 gtk_accel_group_ref(obj);
707 sgtk_obj_cache_add(obj, new);
708 return(new);
709 }
710
sgtk_AccelGroup_sweep(SOBJ obj)711 static void sgtk_AccelGroup_sweep(SOBJ obj)
712 {
713 SWEEPING(obj);
714 if (SGTK_ACCELGROUP(obj)) {
715 gtk_accel_group_unref(SGTK_ACCELGROUP(obj));
716 sgtk_obj_cache_remove(SGTK_ACCELGROUP(obj));
717 SGTK_ACCELGROUP(obj) = NULL;
718 }
719 }
720
sgtk_AccelGroup2obj(int type,void * p)721 static SOBJ sgtk_AccelGroup2obj(int type, void *p)
722 {
723 return(sgtk_AccelGroup_new(p));
724 }
725
sgtk_get_AccelGroup(SOBJ obj)726 void *sgtk_get_AccelGroup(SOBJ obj)
727 {
728 return(SGTK_ACCELGROUP(obj));
729 }
730
731
732 static SOBJ_TYPE_DESCR sgtk_AccelGroup_type_descr = {
733 0,
734 "GtkAccelGroup",
735 NULL, sgtk_AccelGroup_sweep,
736 NULL, NULL,
737 NULL, NULL, NULL, NULL,
738 sgtk_aux_compare,
739 sgtk_AccelGroup2obj, sgtk_get_AccelGroup,
740 };
741
742 /*** GtkStyle ***/
sgtk_Style_new(GtkStyle * obj)743 SOBJ sgtk_Style_new(GtkStyle *obj)
744 {
745 SOBJ new = scm_newcell(SOBJ_T_GtkStyle);
746 SGTK_STYLE(new) = obj;
747 gtk_style_ref(obj);
748 sgtk_obj_cache_add(obj, new);
749 return(new);
750 }
751
sgtk_Style_sweep(SOBJ x)752 static void sgtk_Style_sweep(SOBJ x)
753 {
754 SWEEPING(x);
755 gtk_style_unref(SGTK_STYLE(x));
756 sgtk_obj_cache_remove(SGTK_STYLE(x));
757 }
758
GtkStyle2scm(int type,void * p)759 static SOBJ GtkStyle2scm(int type, void *p)
760 {
761 return(sgtk_Style_new(p));
762 }
763
sgtk_get_Style(SOBJ obj)764 void *sgtk_get_Style(SOBJ obj)
765 {
766 return(SGTK_STYLE(obj));
767 }
768
769 static SOBJ_TYPE_DESCR sgtk_Style_type_descr = {
770 0,
771 "GtkStyle",
772 NULL, sgtk_Style_sweep, /* mark / sweep */
773 NULL, NULL, /* print */
774 NULL, NULL, NULL, NULL, /* parse */
775 sgtk_aux_compare, /* compare */
776 GtkStyle2scm, sgtk_get_Style /* get / set */
777 };
778
779 /*** GtkSelectionData ***/
sgtk_SelectionData_new(GtkSelectionData * obj)780 static SOBJ sgtk_SelectionData_new(GtkSelectionData *obj)
781 {
782 SOBJ new = scm_newcell(SOBJ_T_GtkSelectionData);
783 SGTK_SELECTIONDATA(new) = obj;
784 sgtk_obj_cache_add(obj, new);
785 return(new);
786 }
787
sgtk_SelectionData_sweep(SOBJ obj)788 static void sgtk_SelectionData_sweep(SOBJ obj)
789 {
790 sgtk_obj_cache_remove(SGTK_SELECTIONDATA(obj));
791 }
792
GtkSelectionData2scm(int type,void * p)793 static SOBJ GtkSelectionData2scm(int type, void *p)
794 {
795 return(sgtk_SelectionData_new(p));
796 }
797
sgtk_get_SelectionData(SOBJ obj)798 void *sgtk_get_SelectionData(SOBJ obj)
799 {
800 return(SGTK_SELECTIONDATA(obj));
801 }
802
803 static SOBJ_TYPE_DESCR sgtk_SelectionData_type_descr = {
804 0,
805 "GtkSelectionData",
806 NULL, sgtk_SelectionData_sweep, /* mark / sweep */
807 NULL, NULL, /* print */
808 NULL, NULL, NULL, NULL, /* parse */
809 sgtk_aux_compare, /* compare */
810 GtkSelectionData2scm, sgtk_get_SelectionData /* get / set */
811 };
812
813 /*** GtkCtreeNode ***/
sgtk_CTreeNode_new(GtkCTreeNode * node)814 SOBJ sgtk_CTreeNode_new(GtkCTreeNode *node)
815 {
816 SOBJ new = scm_newcell(SOBJ_T_GtkCTreeNode);
817 SGTK_CTREE_NODE(new) = node;
818 sgtk_obj_cache_add(node, new);
819 return(new);
820 }
821
sgtk_CTreeNode_sweep(SOBJ obj)822 static void sgtk_CTreeNode_sweep(SOBJ obj)
823 {
824 sgtk_obj_cache_remove(SGTK_CTREE_NODE(obj));
825 }
826
GtkCTreeNode2scm(int type,void * p)827 static SOBJ GtkCTreeNode2scm(int type, void *p)
828 {
829 return(sgtk_CTreeNode_new(p));
830 }
831
sgtk_get_CTreeNode(SOBJ obj)832 void *sgtk_get_CTreeNode(SOBJ obj)
833 {
834 return(SGTK_CTREE_NODE(obj));
835 }
836
837 static SOBJ_TYPE_DESCR sgtk_CTreeNode_type_descr = {
838 0,
839 "GtkCTreeNode",
840 NULL, sgtk_CTreeNode_sweep, /* mark / sweep */
841 NULL, NULL,
842 NULL, NULL, NULL, NULL,
843 sgtk_aux_compare,
844 GtkCTreeNode2scm, sgtk_get_CTreeNode /* get / set */
845 };
846
847
848 /*** GtkStyleHelper ***/
sgtk_StyleHelper_new(GtkStyle * style,int type,gpointer array)849 static SOBJ sgtk_StyleHelper_new(GtkStyle *style, int type, gpointer array)
850 {
851 SOBJ new = scm_newcell(SOBJ_T_GtkStyleHelper);
852 sgtk_StyleHelper_Aux *aux = scm_must_alloc(sizeof(sgtk_StyleHelper_Aux));
853
854 SGTK_STYLE_HELPER_AUX(new) = aux;
855 aux->style = gtk_style_ref(style);
856 aux->type = type;
857 aux->array = array;
858 sgtk_obj_cache_add(style, new);
859 return(new);
860 }
861
sgtk_StyleHelper_sweep(SOBJ x)862 static void sgtk_StyleHelper_sweep(SOBJ x)
863 {
864 SWEEPING(x);
865 if (SGTK_STYLE_HELPER_AUX(x)) {
866 gtk_style_unref(SGTK_STYLE_HELPER_AUX(x)->style);
867 sgtk_obj_cache_remove(SGTK_STYLE_HELPER_AUX(x)->style);
868 scm_free(SGTK_STYLE_HELPER_AUX(x));
869 }
870 }
871
sgtk_StyleHelper_get(SOBJ x,int pos)872 static SOBJ sgtk_StyleHelper_get(SOBJ x, int pos)
873 {
874 sgtk_StyleHelper_Aux *aux = SGTK_STYLE_HELPER_AUX(x);
875
876 if (pos < 0 || pos >= 5) SCM_ERR("index out of range", SCM_MKINUM(pos));
877 switch(aux->type) {
878 case STYLE_COLOUR_ARRAY:
879 {
880 GdkColor *array = (GdkColor *)aux->array;
881 return(sgdk_Color_new(&array[pos]));
882 }
883 case STYLE_GC_ARRAY:
884 {
885 GdkGC **array = (GdkGC **)aux->array;
886 return(sgdk_GC_new(array[pos]));
887 }
888 case STYLE_PIXMAP_ARRAY:
889 {
890 GdkWindow **array = (GdkWindow **)aux->array;
891 if (array[pos]) return(sgdk_Window_new(array[pos]));
892 return(NULL);
893 }
894 }
895 g_assert_not_reached();
896 return(NULL);
897 }
898
sgtk_StyleHelper_set(SOBJ x,int pos,SOBJ value)899 static int sgtk_StyleHelper_set(SOBJ x, int pos, SOBJ value)
900 {
901 sgtk_StyleHelper_Aux *aux = SGTK_STYLE_HELPER_AUX(x);
902
903 if (pos < 0 || pos >= 5) SCM_ERR("index out of range", SCM_MKINUM(pos));
904
905 switch(aux->type) {
906 case STYLE_COLOUR_ARRAY:
907 {
908 GdkColor *array = (GdkColor *)aux->array;
909 if (SCM_OBJTYPE(value) != SOBJ_T_GdkColor) SCM_ERR("bad color", value);
910 array[pos] = *SGDK_COLOR(value);
911 return 0;
912 }
913 case STYLE_GC_ARRAY:
914 {
915 GdkGC **array = (GdkGC **)aux->array;
916 if (SCM_OBJTYPE(value) != SOBJ_T_GdkGC) SCM_ERR("bad gc", value);
917 if (array[pos]) gdk_gc_unref(array[pos]);
918 array[pos] = gdk_gc_ref(SGDK_GC(x));
919 return 0;
920 }
921 case STYLE_PIXMAP_ARRAY:
922 {
923 GdkWindow **array = (GdkWindow **)aux->array;
924
925 if (value != NULL && SCM_OBJTYPE(value) != SOBJ_T_GdkWindow)
926 SCM_ERR("bad window", value);
927 if (array[pos]) gdk_pixmap_unref(array[pos]);
928 array[pos] = gdk_pixmap_ref(SGDK_WINDOW(value));
929 return 0;
930 }
931 }
932 g_assert_not_reached();
933 return -1;
934 }
935
936 static SOBJ_TYPE_DESCR sgtk_StyleHelper_type_descr = {
937 0,
938 "GtkStyleHelper",
939 NULL, sgtk_StyleHelper_sweep, /* mark / sweep */
940 NULL, NULL, /* print */
941 NULL, NULL, NULL, NULL, /* parse */
942 NULL, /* compare */
943 NULL, NULL /* get / set */
944 };
945
sgtk_Style_get(SOBJ self,char * attr)946 static SOBJ sgtk_Style_get(SOBJ self, char *attr)
947 {
948 SCM_ERR("sgtk_Style_get: not implemented", NULL);
949 }
950
sgtk_Style_set(SOBJ self,char * key,SOBJ value)951 static int sgtk_Style_set(SOBJ self, char *key, SOBJ value)
952 {
953 SCM_ERR("sgtk_Style_set: not implemented", NULL);
954 }
955
956 /****************************************************************
957 * convert arguments
958 ****************************************************************/
959
960 /*** destroy notify for SGTK_OBJECTS */
sgtk_func_destroy_notify(gpointer data)961 void sgtk_func_destroy_notify(gpointer data)
962 {
963 SOBJ obj = data;
964 #ifdef DEBUG_ALIVE
965 scm_puts("sgtk_func_destroy_notify: "); scm_putx(data);
966 scm_puts(" object="); scm_cprint(obj);
967 #endif
968
969 if (sgtk_func_get(data)) {
970 #ifdef DEBUG_ALIVE
971 scm_puts("DEBUG: remove func object "); scm_putx(data); scm_puts("\n");
972 #endif
973 sgtk_func_remove(data);
974 }
975 }
976
977
978 /*** boxed functions */
979
980 typedef struct {
981 SOBJ (*fromarg)(gpointer boxed);
982 int (*toarg)(gpointer *boxed, SOBJ obj);
983 } SGTK_BOX_FUNCS;
984
985 static GHashTable *boxed_funcs;
986
sgtk_register_boxed(GtkType boxed_type,SOBJ (* fromarg)(gpointer boxed),int (* toarg)(gpointer * boxed,SOBJ obj))987 static void sgtk_register_boxed(GtkType boxed_type,
988 SOBJ (*fromarg)(gpointer boxed),
989 int (*toarg)(gpointer *boxed, SOBJ obj))
990 {
991 SGTK_BOX_FUNCS *fs = g_new(SGTK_BOX_FUNCS, 1);
992 fs->fromarg = fromarg;
993 fs->toarg = toarg;
994 g_hash_table_insert(boxed_funcs, GUINT_TO_POINTER(boxed_type), fs);
995 }
996
997 #define sgtk_get_boxed(type) \
998 (SGTK_BOX_FUNCS *)g_hash_table_lookup(boxed_funcs, GUINT_TO_POINTER(type))
999
1000
1001 /*** Signal handling */
1002 /* forward decl */
1003 static SOBJ sgtk_args2list(guint nargs, GtkArg *args);
1004
1005 /* GtkArg_FromPyObject */
sgtk_scm2arg(GtkArg * arg,SOBJ obj)1006 static int sgtk_scm2arg(GtkArg *arg, SOBJ obj)
1007 {
1008 SOBJ tmp;
1009 int value;
1010
1011 switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
1012 case GTK_TYPE_NONE:
1013 case GTK_TYPE_INVALID:GTK_VALUE_INT(*arg) = 0; break;
1014 case GTK_TYPE_BOOL: GTK_VALUE_BOOL(*arg) = (obj != scm_false); break;
1015 case GTK_TYPE_CHAR:
1016 if (!SCM_CHARP(obj)) return -1;
1017 GTK_VALUE_CHAR(*arg) = SCM_CHAR(obj);
1018 break;
1019 case GTK_TYPE_ENUM:
1020 if ((value = enum_getv(arg->type, obj)) == -1) return -1;
1021 GTK_VALUE_ENUM(*arg) = value;
1022 break;
1023 case GTK_TYPE_FLAGS:
1024 if ((value = flag_getv(arg->type, obj)) == -1) return -1;
1025 GTK_VALUE_FLAGS(*arg) = value;
1026 break;
1027 case GTK_TYPE_INT:
1028 if (!SCM_NUMBERP(obj)) return -1;
1029 GTK_VALUE_INT(*arg) = scm_number2long(obj);
1030 break;
1031 case GTK_TYPE_UINT:
1032 if (!SCM_NUMBERP(obj)) return -1;
1033 GTK_VALUE_UINT(*arg) = scm_number2long(obj);
1034 break;
1035 case GTK_TYPE_LONG:
1036 if (!SCM_NUMBERP(obj)) return -1;
1037 GTK_VALUE_LONG(*arg) = scm_number2long(obj);
1038 break;
1039 case GTK_TYPE_ULONG:
1040 if (!SCM_NUMBERP(obj)) return -1;
1041 GTK_VALUE_ULONG(*arg) = scm_number2long(obj);
1042 break;
1043 case GTK_TYPE_FLOAT:
1044 if (!SCM_NUMBERP(obj)) return -1;
1045 GTK_VALUE_FLOAT(*arg) = scm_number2double(obj);
1046 break;
1047 case GTK_TYPE_DOUBLE:
1048 if (!SCM_NUMBERP(obj)) return -1;
1049 GTK_VALUE_DOUBLE(*arg) = scm_number2double(obj);
1050 break;
1051 case GTK_TYPE_STRING:
1052 if (!SCM_STRINGP(obj)) return -1;
1053 GTK_VALUE_STRING(*arg) = SCM_STR_VALUE(obj);
1054 break;
1055 case GTK_TYPE_OBJECT:
1056 if (!SGTK_OBJECTP(obj)) return -1;
1057 GTK_VALUE_OBJECT(*arg) = SGTK_OBJECT(obj);
1058 case GTK_TYPE_BOXED:
1059 if (arg->type == GTK_TYPE_ACCEL_GROUP) {
1060 if (SCM_OBJTYPE(obj) != SOBJ_T_GtkAccelGroup) return -1;
1061 GTK_VALUE_BOXED(*arg) = SGTK_ACCELGROUP(obj);
1062 } else if (arg->type == GTK_TYPE_STYLE) {
1063 if (SCM_OBJTYPE(obj) != SOBJ_T_GtkStyle) return -1;
1064 GTK_VALUE_BOXED(*arg) = SGTK_STYLE(obj);
1065 } else if (arg->type == GTK_TYPE_GDK_EVENT) {
1066 if (SCM_OBJTYPE(obj) != SOBJ_T_GdkEvent) return -1;
1067 GTK_VALUE_BOXED(*arg) = SGDK_EVENT(obj);
1068 } else if (arg->type == GTK_TYPE_GDK_FONT) {
1069 if (SCM_OBJTYPE(obj) != SOBJ_T_GdkFont) return -1;
1070 GTK_VALUE_BOXED(*arg) = SGDK_FONT(obj);
1071 } else if (arg->type == GTK_TYPE_GDK_COLOR) {
1072 if (obj && SCM_OBJTYPE(obj) != SOBJ_T_GdkColor) return -1;
1073 GTK_VALUE_BOXED(*arg) = (obj) ? SGDK_COLOR(obj) : NULL;
1074 } else if (arg->type == GTK_TYPE_GDK_WINDOW) {
1075 if (obj && SCM_OBJTYPE(obj) != SOBJ_T_GdkWindow) return -1;
1076 GTK_VALUE_BOXED(*arg) = (obj) ? SGDK_WINDOW(obj) : NULL;
1077 } else if (arg->type == GTK_TYPE_GDK_COLORMAP) {
1078 if (obj && SCM_OBJTYPE(obj) != SOBJ_T_GdkColormap) return -1;
1079 GTK_VALUE_BOXED(*arg) = (obj) ? SGDK_COLORMAP(obj) : NULL;
1080 } else if (arg->type == GTK_TYPE_GDK_DRAG_CONTEXT) {
1081 if (obj && SCM_OBJTYPE(obj) != SOBJ_T_GdkDragContext) return -1;
1082 GTK_VALUE_BOXED(*arg) = (obj) ? SGDK_DRAGCONTEXT(obj) : NULL;
1083 } else if (arg->type == GTK_TYPE_SELECTION_DATA) {
1084 if (SCM_OBJTYPE(obj) != SOBJ_T_GtkSelectionData) return -1;
1085 GTK_VALUE_BOXED(*arg) = SGTK_SELECTIONDATA(obj);
1086 } else if (arg->type == GTK_TYPE_CTREE_NODE) {
1087 if (obj && SCM_OBJTYPE(obj) != SOBJ_T_GtkSelectionData) return -1;
1088 GTK_VALUE_BOXED(*arg) = (obj) ? SGTK_SELECTIONDATA(obj) : NULL;
1089 } else {
1090 SGTK_BOX_FUNCS *fs= sgtk_get_boxed(arg->type);
1091 if (fs && fs->toarg) {
1092 if (fs->toarg(&(GTK_VALUE_BOXED(*arg)), obj))
1093 return -1;
1094 } else if (SCM_POINTERP(obj))
1095 GTK_VALUE_BOXED(*arg) = SCM_POINTER(obj);
1096 else
1097 return -1;
1098 }
1099 break;
1100 case GTK_TYPE_POINTER:
1101 if (!SCM_POINTERP(obj)) return -1;
1102 GTK_VALUE_BOXED(*arg) = SCM_POINTER(obj);
1103 break;
1104 case GTK_TYPE_FOREIGN:
1105 GTK_VALUE_FOREIGN(*arg).data = obj;
1106 GTK_VALUE_FOREIGN(*arg).notify = sgtk_func_destroy_notify;
1107 break;
1108 case GTK_TYPE_SIGNAL:
1109 if (!SCM_PROCP(obj)) return -1;
1110 GTK_VALUE_SIGNAL(*arg).f = NULL;
1111 GTK_VALUE_SIGNAL(*arg).d = obj;
1112 break;
1113 case GTK_TYPE_CALLBACK:
1114 if (!SCM_PROCP(obj)) return -1;
1115 GTK_VALUE_CALLBACK(*arg).marshal =
1116 (GtkCallbackMarshal)sgtk_callback_marshal;
1117 GTK_VALUE_CALLBACK(*arg).data = obj;
1118 GTK_VALUE_CALLBACK(*arg).notify = sgtk_func_destroy_notify;
1119 break;
1120 case GTK_TYPE_ARGS:
1121 case GTK_TYPE_C_CALLBACK:
1122 fprintf(stderr, "unsupported type");
1123 g_assert_not_reached();
1124 return -1;
1125 }
1126 return 0;
1127 }
1128
1129
1130 /* GtkArg_AsPyObject */
sgtk_arg2scm(GtkArg * arg)1131 static SOBJ sgtk_arg2scm(GtkArg *arg)
1132 {
1133 switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
1134 case GTK_TYPE_INVALID:
1135 case GTK_TYPE_NONE:
1136 return NULL;
1137
1138 case GTK_TYPE_CHAR: return scm_mkchar(GTK_VALUE_CHAR(*arg));
1139 case GTK_TYPE_BOOL: return SCM_MKBOOL(GTK_VALUE_BOOL(*arg));
1140 case GTK_TYPE_ENUM:
1141 case GTK_TYPE_FLAGS:
1142 case GTK_TYPE_INT: return scm_int2num(GTK_VALUE_INT(*arg));
1143 case GTK_TYPE_UINT: return scm_int2num(GTK_VALUE_UINT(*arg));
1144 case GTK_TYPE_LONG: return scm_int2num(GTK_VALUE_LONG(*arg));
1145 case GTK_TYPE_ULONG: return scm_int2num(GTK_VALUE_ULONG(*arg));
1146 case GTK_TYPE_FLOAT: return scm_flt2num(GTK_VALUE_FLOAT(*arg));
1147 case GTK_TYPE_DOUBLE: return scm_flt2num(GTK_VALUE_DOUBLE(*arg));
1148 case GTK_TYPE_STRING:
1149 return GTK_VALUE_STRING(*arg) ?
1150 scm_mkstring(GTK_VALUE_STRING(*arg)) : NULL;
1151 case GTK_TYPE_ARGS:
1152 return sgtk_args2list(GTK_VALUE_ARGS(*arg).n_args,
1153 GTK_VALUE_ARGS(*arg).args);
1154 case GTK_TYPE_OBJECT:
1155 {
1156 SOBJ obj = sgtk_obj_cache_get(GTK_VALUE_OBJECT(*arg));
1157 if (obj == scm_undefined) {
1158 scm_puts("sgtk_arg2scm: oops: object not alive");
1159 scm_putx(GTK_VALUE_OBJECT(*arg));
1160 scm_puts("\n");
1161 return(NULL);
1162 }
1163 return obj;
1164 }
1165
1166 case GTK_TYPE_POINTER:
1167 return scm_mk_static_pointer(GTK_VALUE_POINTER(*arg));
1168
1169 case GTK_TYPE_BOXED:
1170 if (arg->type == GTK_TYPE_ACCEL_GROUP)
1171 return sgtk_AccelGroup_new(GTK_VALUE_BOXED(*arg));
1172 else if (arg->type == GTK_TYPE_STYLE)
1173 return sgtk_Style_new(GTK_VALUE_BOXED(*arg));
1174 else if (arg->type == GTK_TYPE_GDK_EVENT)
1175 return sgdk_Event_new(GTK_VALUE_BOXED(*arg));
1176 else if (arg->type == GTK_TYPE_GDK_FONT)
1177 return sgdk_Font_new(GTK_VALUE_BOXED(*arg));
1178 else if (arg->type == GTK_TYPE_GDK_COLOR)
1179 return sgdk_Color_new(GTK_VALUE_BOXED(*arg));
1180 else if (arg->type == GTK_TYPE_GDK_WINDOW)
1181 return sgdk_Window_new(GTK_VALUE_BOXED(*arg));
1182 else if (arg->type == GTK_TYPE_GDK_COLORMAP)
1183 return sgdk_Colormap_new(GTK_VALUE_BOXED(*arg));
1184 else if (arg->type == GTK_TYPE_GDK_DRAG_CONTEXT)
1185 return sgdk_DragContext_new(GTK_VALUE_BOXED(*arg));
1186 else if (arg->type == GTK_TYPE_SELECTION_DATA)
1187 return sgtk_SelectionData_new(GTK_VALUE_BOXED(*arg));
1188 else if (arg->type == GTK_TYPE_CTREE_NODE) {
1189 if (GTK_VALUE_BOXED(*arg))
1190 return sgtk_CTreeNode_new(GTK_VALUE_BOXED(*arg));
1191 return NULL;
1192 } else {
1193 SGTK_BOX_FUNCS *fs = sgtk_get_boxed(arg->type);
1194 if (fs && fs->fromarg)
1195 return fs->fromarg(GTK_VALUE_BOXED(*arg));
1196 return scm_mk_static_pointer(GTK_VALUE_BOXED(*arg));
1197 }
1198 case GTK_TYPE_FOREIGN: return (SOBJ)GTK_VALUE_FOREIGN(*arg).data;
1199 case GTK_TYPE_CALLBACK: return (SOBJ)GTK_VALUE_CALLBACK(*arg).data;
1200 case GTK_TYPE_SIGNAL: return (SOBJ)GTK_VALUE_SIGNAL(*arg).d;
1201 default:
1202 g_assert_not_reached();
1203 break;
1204 }
1205 return NULL;
1206 }
1207
1208 /*** GtkRet_FromPyObject ***/
1209 /* set a GtkArg structure's data from a scheme object, using the GTK_RETLOC_*
1210 * routines. If it can't make the conversion, set the return to a zero
1211 * equivalent. */
sgtk_scm2ret(GtkArg * ret,SOBJ obj)1212 static void sgtk_scm2ret(GtkArg *ret, SOBJ obj)
1213 {
1214 int value;
1215
1216 switch(GTK_FUNDAMENTAL_TYPE(ret->type)) {
1217 case GTK_TYPE_NONE:
1218 case GTK_TYPE_INVALID: break;
1219 case GTK_TYPE_BOOL:
1220 *GTK_RETLOC_BOOL(*ret) = (obj != scm_false);
1221 break;
1222 case GTK_TYPE_CHAR:
1223 if (SCM_CHARP(obj))
1224 *GTK_RETLOC_CHAR(*ret) = SCM_CHAR(obj);
1225 else if (SCM_STRINGP(obj))
1226 *GTK_RETLOC_CHAR(*ret) = SCM_STR_VALUE(obj)[0];
1227 else
1228 *GTK_RETLOC_CHAR(*ret) = 0;
1229 break;
1230 case GTK_TYPE_ENUM:
1231 value = enum_getv(ret->type, obj);
1232 *GTK_RETLOC_ENUM(*ret) = (value == -1) ? 0 : value;
1233 break;
1234 case GTK_TYPE_FLAGS:
1235 value = flag_getv(ret->type, obj);
1236 *GTK_RETLOC_FLAGS(*ret) = (value == -1) ? 0 : value;
1237 break;
1238 case GTK_TYPE_INT:
1239 *GTK_RETLOC_INT(*ret) = SCM_NUMBERP(obj) ? scm_number2long(obj) : 0;
1240 break;
1241 case GTK_TYPE_UINT:
1242 *GTK_RETLOC_UINT(*ret) = SCM_NUMBERP(obj) ? scm_number2long(obj) : 0;
1243 break;
1244 case GTK_TYPE_LONG:
1245 *GTK_RETLOC_LONG(*ret) = SCM_NUMBERP(obj) ? scm_number2long(obj) : 0;
1246 break;
1247 case GTK_TYPE_ULONG:
1248 *GTK_RETLOC_ULONG(*ret) = SCM_NUMBERP(obj) ? scm_number2long(obj) : 0;
1249 break;
1250 case GTK_TYPE_FLOAT:
1251 *GTK_RETLOC_FLOAT(*ret) = SCM_NUMBERP(obj) ? scm_number2double(obj) : 0;
1252 break;
1253 case GTK_TYPE_DOUBLE:
1254 *GTK_RETLOC_DOUBLE(*ret) = SCM_NUMBERP(obj) ? scm_number2double(obj) : 0;
1255 break;
1256 case GTK_TYPE_STRING:
1257 *GTK_RETLOC_STRING(*ret) =
1258 SCM_STRINGP(obj) ? g_strdup(SCM_STR_VALUE(obj)) : NULL;
1259 break;
1260 case GTK_TYPE_OBJECT:
1261 *GTK_RETLOC_OBJECT(*ret) = SGTK_OBJECTP(obj) ? SGTK_OBJECT(obj) : NULL;
1262 break;
1263 case GTK_TYPE_BOXED:
1264 if (ret->type == GTK_TYPE_ACCEL_GROUP) {
1265 *GTK_RETLOC_BOXED(*ret) =
1266 (SCM_OBJTYPE(obj)==SOBJ_T_GtkAccelGroup) ? SGTK_ACCELGROUP(obj) : NULL;
1267 } else if (ret->type == GTK_TYPE_STYLE) {
1268 *GTK_RETLOC_BOXED(*ret) =
1269 (SCM_OBJTYPE(obj)==SOBJ_T_GtkStyle) ? SGTK_STYLE(obj) : NULL;
1270 } else if (ret->type == GTK_TYPE_GDK_EVENT) {
1271 *GTK_RETLOC_BOXED(*ret) =
1272 (SCM_OBJTYPE(obj)==SOBJ_T_GdkEvent) ? SGDK_EVENT(obj) : NULL;
1273 } else if (ret->type == GTK_TYPE_GDK_FONT) {
1274 *GTK_RETLOC_BOXED(*ret) =
1275 (SCM_OBJTYPE(obj)==SOBJ_T_GdkFont) ? SGDK_FONT(obj) : NULL;
1276 } else if (ret->type == GTK_TYPE_GDK_COLOR) {
1277 *GTK_RETLOC_BOXED(*ret) =
1278 (SCM_OBJTYPE(obj)==SOBJ_T_GdkColor) ? SGDK_COLOR(obj) : NULL;
1279 } else if (ret->type == GTK_TYPE_GDK_WINDOW) {
1280 *GTK_RETLOC_BOXED(*ret) =
1281 (SCM_OBJTYPE(obj)==SOBJ_T_GdkWindow) ? SGDK_WINDOW(obj) : NULL;
1282 } else if (ret->type == GTK_TYPE_GDK_COLORMAP) {
1283 *GTK_RETLOC_BOXED(*ret) =
1284 (SCM_OBJTYPE(obj)==SOBJ_T_GdkColormap) ? SGDK_COLORMAP(obj) : NULL;
1285 } else if (ret->type == GTK_TYPE_GDK_DRAG_CONTEXT) {
1286 *GTK_RETLOC_BOXED(*ret) =
1287 (SCM_OBJTYPE(obj)==SOBJ_T_GdkDragContext) ? SGDK_DRAGCONTEXT(obj):NULL;
1288 } else if (ret->type == GTK_TYPE_SELECTION_DATA) {
1289 *GTK_RETLOC_BOXED(*ret) =
1290 (SCM_OBJTYPE(obj)==SOBJ_T_GtkSelectionData) ?
1291 SGTK_SELECTIONDATA(obj) : NULL;
1292 } else if (ret->type == GTK_TYPE_CTREE_NODE) {
1293 *GTK_RETLOC_BOXED(*ret) =
1294 (SCM_OBJTYPE(obj)==SOBJ_T_GtkCTreeNode) ? SGTK_CTREE_NODE(obj) : NULL;
1295 } else {
1296 SGTK_BOX_FUNCS *fs = sgtk_get_boxed(ret->type);
1297 if (fs && fs->toarg) {
1298 if (fs->toarg(GTK_RETLOC_BOXED(*ret), obj))
1299 *GTK_RETLOC_BOXED(*ret) = NULL;
1300 } else {
1301 *GTK_RETLOC_BOXED(*ret) =
1302 SCM_POINTERP(obj) ? SCM_POINTER(obj) : NULL;
1303 }
1304 }
1305 break;
1306 case GTK_TYPE_POINTER:
1307 *GTK_RETLOC_POINTER(*ret) = SCM_POINTERP(obj) ? SCM_POINTER(obj) : NULL;
1308 break;
1309 default:
1310 g_assert_not_reached();
1311 break;
1312 }
1313 }
1314
sgtk_args2list(guint nargs,GtkArg * args)1315 static SOBJ sgtk_args2list(guint nargs, GtkArg *args)
1316 {
1317 SOBJ l;
1318 int i;
1319
1320 l = NULL;
1321 for (i = 0; i < nargs; i++) {
1322 l = scm_cons(sgtk_arg2scm(args + i), l);
1323 }
1324 return(scm_reverse(l));
1325 }
1326
1327 #ifdef OLD
sgtk_arg2array(guint narg_in,GtkArg * arg_in,SOBJ * out)1328 static void sgtk_arg2array(guint narg_in, GtkArg *arg_in, SOBJ *out)
1329 {
1330 int i;
1331 for (i = 0; i < narg_in; i++) {
1332 out[i] = sgtk_arg2scm(arg_in + i);
1333 }
1334 }
1335 #endif
1336
sgtk_callback_marshal(GtkObject * o,gpointer data,guint nargs,GtkArg * args)1337 void sgtk_callback_marshal(GtkObject *o, gpointer data,guint nargs, GtkArg *args)
1338 {
1339 SOBJ ret;
1340 SOBJ funarg[SGTK_MAX_CALLBACK_ARGS];
1341 int nfunarg, i;
1342
1343 /* build argument list to call function
1344 The argument list contains:
1345 - the object
1346 - the arguments converted from the GtkArg
1347 - the extra list of arguments
1348 The data argument contain a doted pair (func . extra_data)
1349 */
1350
1351 if (nargs >= (SGTK_MAX_CALLBACK_ARGS - 2)) {
1352 fprintf(stderr, "too many args: max=%d got=%d -- callback not run\n",
1353 SGTK_MAX_CALLBACK_ARGS - 2, nargs);
1354 return;
1355 }
1356 if (!SCM_PAIRP((SOBJ)data)) {
1357 fprintf(stderr, "expected (func . data) -- callback not run\n");
1358 return;
1359 }
1360
1361 nfunarg = 0;
1362 if ((ret = sgtk_obj_cache_get(o)) == scm_undefined) {
1363 fprintf(stderr, "callback object %p not alive -- creating one\n", o);
1364 ret = sgtk_object_new(o);
1365 }
1366 /*** debugging message */
1367 /* scm_puts("CALLBACK for "); scm_cprint(ret); */
1368
1369 funarg[nfunarg++] = ret;
1370 for (i = 0; i < nargs; i++) {
1371 funarg[nfunarg++] = sgtk_arg2scm(args + i);
1372 }
1373 funarg[nfunarg++] = SCM_CDR((SOBJ)data);
1374 if ((ret = scm_apply_v(SCM_CAR((SOBJ)data), nfunarg, funarg)) == NULL) {
1375 fprintf(stderr, "callback func returned NULL\n");
1376 return;
1377 }
1378 sgtk_scm2ret(args + nargs, ret);
1379 }
1380
sgtk_signal_connect(SOBJ obj,SOBJ name,SOBJ func,SOBJ data)1381 SOBJ sgtk_signal_connect(SOBJ obj, SOBJ name, SOBJ func, SOBJ data)
1382 {
1383 int sig;
1384
1385 if (!SGTK_OBJECTP(obj)) SCM_ERR("bad gtk object", obj);
1386 if (!SCM_STRINGP(name)) SCM_ERR("bad signal name", name);
1387 if (!SCM_CLOSUREP(func)) SCM_ERR("bad function", func);
1388
1389 func = scm_cons(func, data);
1390 sgtk_func_add(func, func);
1391
1392 sig = gtk_signal_connect_full(SGTK_OBJECT(obj),
1393 SCM_STR_VALUE(name), NULL,
1394 sgtk_callback_marshal,
1395 func,
1396 sgtk_func_destroy_notify, FALSE, FALSE);
1397 return(scm_int2num(sig));
1398 }
1399
1400 #ifdef LIBGLADE_SUPPORT
1401
sglade_xml_object_new(GladeXML * xml)1402 SOBJ sglade_xml_object_new(GladeXML *xml)
1403 {
1404 SOBJ new = scm_newcell(SOBJ_T_GLADE_XML);
1405 SGLADE_XML(new) = xml;
1406 gtk_object_ref(GTK_OBJECT(xml));
1407 sgtk_obj_cache_add(xml, new);
1408 return(new);
1409 }
1410
sglade_xml_sweep(SOBJ x)1411 static void sglade_xml_sweep(SOBJ x)
1412 {
1413 SWEEPING(x);
1414 if (SGLADE_XML(x)) {
1415 GtkObject *o = GTK_OBJECT(SGLADE_XML(x));
1416 sgtk_obj_cache_remove(o);
1417 gtk_object_unref(o);
1418 SCM_CAR(x) = SCM_CDR(x) = NULL;
1419 }
1420 }
1421
sglade_xml_print(SOBJ x,PORT * p)1422 static void sglade_xml_print(SOBJ x, PORT *p)
1423 {
1424 port_puts(p, "#<GladeXML at ");
1425 port_putx(p, SGLADE_XML(x));
1426 port_puts(p, ">");
1427 }
1428
sglade_xml2scm(int type,void * p)1429 static SOBJ sglade_xml2scm(int type, void *p)
1430 {
1431 return(sglade_xml_object_new(p));
1432 }
1433
sglade_scm2xml(SOBJ x)1434 static void *sglade_scm2xml(SOBJ x)
1435 {
1436 return( (x == NULL) ? NULL : SGLADE_XML(x));
1437 }
1438
1439 static SOBJ_TYPE_DESCR sglade_xml_type_descr = {
1440 0,
1441 "GladeXML",
1442 NULL, sglade_xml_sweep, /* mark / sweep */
1443 sglade_xml_print, sglade_xml_print, /* print */
1444 NULL, NULL, NULL, NULL, /* parse */
1445 sgtk_aux_compare, /* compare */
1446 sglade_xml2scm, sglade_scm2xml /* get / set */
1447 };
1448
connect_one(const gchar * handler_name,GtkObject * object,const gchar * signal_name,const gchar * signal_data,GtkObject * connect_object,gboolean after,gpointer user_data)1449 static void connect_one(const gchar *handler_name, GtkObject *object,
1450 const gchar *signal_name, const gchar *signal_data,
1451 GtkObject *connect_object, gboolean after,
1452 gpointer user_data)
1453 {
1454 SOBJ cnxobj;
1455 SOBJ callback = user_data;
1456 SOBJ func;
1457 int sig;
1458
1459 if (connect_object) {
1460 cnxobj = sgtk_object_new(connect_object);
1461 if (!SCM_CLOSUREP(callback)) SCM_ERR("bad closure", callback);
1462 if (SCM_PAIRP(callback)) {
1463 } else {
1464 }
1465 }
1466 func = scm_cons(callback, NULL);
1467 sgtk_func_add(func, func);
1468 gtk_signal_connect_full(object, signal_name, NULL,
1469 sgtk_callback_marshal,
1470 func,
1471 sgtk_func_destroy_notify, FALSE, after);
1472 }
1473
sglade_xml_signal_connect(SOBJ xml,SOBJ handlername,SOBJ func)1474 SOBJ sglade_xml_signal_connect(SOBJ xml, SOBJ handlername, SOBJ func)
1475 {
1476 if (!SGLADE_XMLP(xml)) SCM_ERR("bad glade xml", xml);
1477 if (!SCM_STRINGP(handlername)) SCM_ERR("bad handlername", handlername);
1478 if (!SCM_CLOSUREP(func)) SCM_ERR("bad func", func);
1479
1480 glade_xml_signal_connect_full(SGLADE_XML(xml),
1481 SCM_STR_VALUE(handlername),
1482 connect_one,
1483 (void*)func);
1484 return(scm_undefined);
1485 }
1486
1487 #endif /* LIBGLADE_SUPPORT */
1488
1489
1490 /*** Idle functions ***/
sgtk_idle_handler(SOBJ proc)1491 static int sgtk_idle_handler(SOBJ proc)
1492 {
1493 return( scm_apply0(proc) != scm_false );
1494 }
1495
1496
sgtk_idle_add(SOBJ proc)1497 SOBJ sgtk_idle_add(SOBJ proc)
1498 {
1499 int id;
1500
1501 sgtk_func_add(proc, proc);
1502 id = gtk_idle_add_full(GTK_PRIORITY_DEFAULT,
1503 (void*)sgtk_idle_handler,
1504 NULL,
1505 (void*)proc,
1506 sgtk_func_destroy_notify);
1507 return(SCM_MKINUM(id));
1508 }
1509
1510
sgtk_timeout_handler(SOBJ proc)1511 static int sgtk_timeout_handler(SOBJ proc)
1512 {
1513 return( scm_apply0(proc) != scm_false );
1514 }
1515
sgtk_timeout_add(SOBJ timeout,SOBJ proc)1516 SOBJ sgtk_timeout_add(SOBJ timeout, SOBJ proc)
1517 {
1518 int id;
1519 if (!SCM_INUMP(timeout)) SCM_ERR("bad timeout", timeout);
1520 if (!SCM_CLOSUREP(proc)) SCM_ERR("bad func", proc);
1521
1522 id = gtk_timeout_add_full(SCM_INUM(timeout),
1523 (void*)sgtk_timeout_handler,
1524 NULL,
1525 (void*)proc,
1526 sgtk_func_destroy_notify);
1527 return(SCM_MKINUM(id));
1528 }
1529
1530
1531 /*** Utilities ***/
1532 #include "sgtk-typep.c"
1533
1534 /*** misc wrapper ***/
1535
sgdk_window_get_pointer(SOBJ win)1536 SOBJ sgdk_window_get_pointer(SOBJ win)
1537 {
1538 int x, y;
1539 GdkModifierType state;
1540 if (SCM_OBJTYPE(win) != SOBJ_T_GdkWindow)
1541 SCM_ERR("gdk-window-get-pointer: bad window", win);
1542
1543 gdk_window_get_pointer(SGDK_WINDOW(win), &x, &y, &state);
1544 return(SCM_LIST3(SCM_MKINUM(x), SCM_MKINUM(y), SCM_MKINUM(state)));
1545 }
1546
1547 #ifdef OOP
sgtk_event_motion_get(GdkEventMotion * event)1548 SOBJ sgtk_event_motion_get(GdkEventMotion *event)
1549 {
1550 SOBJ ev = scm_object_clone(sgtk_event_object);
1551 scm_object_send(ev, scm_mkatom("type!"), SCM_MKINUM(event->type));
1552 scm_object_send(ev, scm_mkatom("window!"),sgtk_window_new(event->window));
1553 scm_object_send(ev, scm_mkatom("x"), scm_mkfnum(event->x));
1554 return(ev);
1555 }
1556 #endif
1557
1558 /*E* (gdk-event-window EVENT) => GDKWIN */
sgdk_event_window(SOBJ e)1559 SOBJ sgdk_event_window(SOBJ e)
1560 {
1561 return(sgdk_Window_new(SGDK_EVENT(e)->any.window));
1562 }
1563 /*E* (gdk-event-motion-hint EVENT) => BOOL */
sgtk_event_motion_hint(SOBJ e)1564 SOBJ sgtk_event_motion_hint(SOBJ e)
1565 {
1566 return(SCM_MKBOOL(((GdkEventMotion *)SGDK_EVENT(e))->is_hint));
1567 }
1568 /*E* (gdk-event-motion-x EVENT) => INT */
sgtk_event_motion_x(SOBJ e)1569 SOBJ sgtk_event_motion_x(SOBJ e)
1570 {
1571 return(SCM_MKINUM((int)((GdkEventMotion *)SGDK_EVENT(e))->x));
1572 }
1573 /*E* (gdk-event-motion-y EVENT) => INT */
sgtk_event_motion_y(SOBJ e)1574 SOBJ sgtk_event_motion_y(SOBJ e)
1575 {
1576 return(SCM_MKINUM((int)((GdkEventMotion *)SGDK_EVENT(e))->y));
1577 }
1578 /*E* (gdk-event-motion-state EVENT) => INT */
sgtk_event_motion_state(SOBJ e)1579 SOBJ sgtk_event_motion_state(SOBJ e)
1580 {
1581 return(SCM_MKINUM((int)((GdkEventMotion *)SGDK_EVENT(e))->state));
1582 }
1583
1584 /*E* (gdk-event-area-x EVENT) => INT */
sgtk_event_area_x(SOBJ e)1585 SOBJ sgtk_event_area_x(SOBJ e)
1586 {
1587 return(SCM_MKINUM((int)((GdkEventExpose *)SGDK_EVENT(e))->area.x));
1588 }
1589
1590 /*E* (gdk-event-area-y EVENT) => INT */
sgtk_event_area_y(SOBJ e)1591 SOBJ sgtk_event_area_y(SOBJ e)
1592 {
1593 return(SCM_MKINUM((int)((GdkEventExpose *)SGDK_EVENT(e))->area.y));
1594 }
1595
1596 /*E* (gdk-event-area-width EVENT) => INT */
sgtk_event_area_width(SOBJ e)1597 SOBJ sgtk_event_area_width(SOBJ e)
1598 {
1599 return(SCM_MKINUM((int)((GdkEventExpose *)SGDK_EVENT(e))->area.width));
1600 }
1601
1602 /*E* (gdk-event-area-height EVENT) => INT */
sgtk_event_area_height(SOBJ e)1603 SOBJ sgtk_event_area_height(SOBJ e)
1604 {
1605 return(SCM_MKINUM((int)((GdkEventExpose *)SGDK_EVENT(e))->area.height));
1606 }
1607
1608 /*E* (gdk-color-parse-new SPEC) => GDKCOLOR */
sgtk_color_parse_new(SOBJ spec)1609 SOBJ sgtk_color_parse_new(SOBJ spec)
1610 {
1611 GdkColor color;
1612
1613 if (!SCM_STRINGP(spec)) SCM_ERR("bad spec", spec);
1614 if (gdk_color_parse(SCM_STR_VALUE(spec), &color)) {
1615 return(sgdk_Color_new(&color));
1616 }
1617 return(NULL);
1618 }
1619
1620
1621 /*** GTK_TEXT fields ***/
1622 /*E* (gtk-text-get-hadj TEXT) => ADJ */
sgtk_text_get_hadj(SOBJ text)1623 SOBJ sgtk_text_get_hadj(SOBJ text)
1624 {
1625 return(sgtk_object_new((GtkObject*)(GTK_TEXT(SGTK_WIDGET(text))->hadj)));
1626 }
1627
1628 /*E* (gtk-text-get-vadj TEXT) => ADJ */
sgtk_text_get_vadj(SOBJ text)1629 SOBJ sgtk_text_get_vadj(SOBJ text)
1630 {
1631 return(sgtk_object_new((GtkObject*)(GTK_TEXT(SGTK_WIDGET(text))->vadj)));
1632 }
1633
1634 /*** modal file selection dialog */
1635
1636 static char *sgtk_filesel_fname;
1637
1638 /* save selected filename to sgtk_filesel_fname */
sgtk_filesel_ok(GtkWidget * w,GtkFileSelection * fs)1639 int sgtk_filesel_ok( GtkWidget *w, GtkFileSelection *fs )
1640 {
1641 g_print("sgtk_filesel_ok:\n");
1642 sgtk_filesel_fname =
1643 strdup(gtk_file_selection_get_filename(GTK_FILE_SELECTION(fs)));
1644 gtk_widget_destroy(GTK_WIDGET(fs));
1645 return(FALSE);
1646 }
1647
sgtk_filesel_destroy(GtkWidget * widget,GtkFileSelection * fs)1648 static int sgtk_filesel_destroy( GtkWidget *widget, GtkFileSelection *fs)
1649 {
1650 g_print("sgtk_filesel_destroy\n");
1651 gtk_main_quit();
1652 return(FALSE);
1653 }
1654
1655 /*E* (gtk-file-select TITLE FNAME) => FNAME */
sgtk_file_select(SOBJ title,SOBJ fname)1656 SOBJ sgtk_file_select(SOBJ title, SOBJ fname)
1657 {
1658 GtkWidget *fs;
1659
1660 if (!SCM_STRINGP(title)) SCM_ERR("bad title", title);
1661 if (fname && !SCM_STRINGP(fname)) SCM_ERR("bad filename", fname);
1662
1663 if (sgtk_filesel_fname) free(sgtk_filesel_fname);
1664 sgtk_filesel_fname = NULL;
1665
1666 fs = gtk_file_selection_new(SCM_STR_VALUE(fname));
1667
1668 gtk_window_set_modal(GTK_WINDOW(fs), TRUE);
1669
1670 gtk_signal_connect (GTK_OBJECT (fs), "destroy",
1671 (GtkSignalFunc)sgtk_filesel_destroy, fs);
1672
1673 /* Connect the ok_button to file_ok_sel function */
1674 gtk_signal_connect (GTK_OBJECT(GTK_FILE_SELECTION(fs)->ok_button),
1675 "clicked", (GtkSignalFunc)sgtk_filesel_ok, fs );
1676
1677 /* Connect the cancel_button to destroy the widget */
1678 gtk_signal_connect_object(GTK_OBJECT(GTK_FILE_SELECTION(fs)->cancel_button),
1679 "clicked", (GtkSignalFunc) gtk_widget_destroy,
1680 GTK_OBJECT(fs));
1681
1682 /* Lets set the filename, as if this were a save dialog, and we are giving
1683 a default filename */
1684 if (fname) {
1685 gtk_file_selection_set_filename (GTK_FILE_SELECTION(fs),
1686 SCM_STR_VALUE(fname));
1687 }
1688
1689 gtk_widget_show(fs);
1690 gtk_main();
1691 gtk_widget_destroy(fs);
1692 return(scm_mkstring(sgtk_filesel_fname));
1693 }
1694
1695
1696 /*E* (gtk-adjustment-set-all OBJ VALUE LOWER UPPER STEP_INCR PAGE_INCR PAGE_SIZE) => #undef */
sgtk_adjustment_set_all(SOBJ obj,SOBJ val,SOBJ low,SOBJ upr,SOBJ step_incr,SOBJ page_incr,SOBJ page_size)1697 SOBJ sgtk_adjustment_set_all(SOBJ obj, SOBJ val, SOBJ low, SOBJ upr,
1698 SOBJ step_incr, SOBJ page_incr, SOBJ page_size)
1699 {
1700 GtkAdjustment *adj;
1701
1702 if (!SGTK_OBJECTP(obj)) SCM_ERR("bad gtk object", obj);
1703 if (!SCM_NUMBERP(val)) SCM_ERR("bad value", val);
1704 if (!SCM_NUMBERP(low)) SCM_ERR("bad lower", low);
1705 if (!SCM_NUMBERP(upr)) SCM_ERR("bad upper", upr);
1706 if (!SCM_NUMBERP(step_incr)) SCM_ERR("bad step increment", step_incr);
1707 if (!SCM_NUMBERP(page_incr)) SCM_ERR("bad page increment", page_incr);
1708 if (!SCM_NUMBERP(page_size)) SCM_ERR("bad page size", page_size);
1709
1710 adj = GTK_ADJUSTMENT(SGTK_OBJECT(obj));
1711 adj->value = scm_number2double(val);
1712 adj->lower = scm_number2double(low);
1713 adj->upper = scm_number2double(upr);
1714 adj->step_increment = scm_number2double(step_incr);
1715 adj->page_increment = scm_number2double(page_incr);
1716 adj->page_size = scm_number2double(page_size);
1717
1718 return(scm_undefined);
1719 }
1720
1721 /*E* (gtk-adjustment-get RANGE) => ADJ */
sgtk_adjustment_get(SOBJ range)1722 SOBJ sgtk_adjustment_get(SOBJ range)
1723 {
1724 if (!SGTK_OBJECTP(range)) SCM_ERR("bad object", range);
1725 return(sgtk_object_new
1726 (GTK_OBJECT(GTK_RANGE(SGTK_OBJECT(range))->adjustment)));
1727 }
1728
1729 /*E* (gtk-adjustment-get-value RANGE) => VALUE */
sgtk_adjustment_get_value(SOBJ range)1730 SOBJ sgtk_adjustment_get_value(SOBJ range)
1731 {
1732 if (!SGTK_OBJECTP(range)) SCM_ERR("bad object", range);
1733 return(scm_mkfnum(GTK_RANGE(SGTK_OBJECT(range))->adjustment->value));
1734 }
1735
1736 /*** get window */
1737 /*E* (gtk-widget-get-window GTKOBJ) => GDKWIN */
sgtk_widget_get_window(SOBJ x)1738 SOBJ sgtk_widget_get_window(SOBJ x)
1739 {
1740 if (!SGTK_OBJECTP(x)) SCM_ERR("bad widget", x);
1741 /* printf("gtk-widget-get-window: window=%p\n", SGTK_WIDGET(x)->window); */
1742 return(sgdk_Window_new(SGTK_WIDGET(x)->window));
1743 }
1744
1745 /*** get widget size */
1746 /*E* (gtk-widget-get-size WIDGET) => (WIDTH HEIGHT) */
sgtk_widget_get_size(SOBJ x)1747 SOBJ sgtk_widget_get_size(SOBJ x)
1748 {
1749 if (!SGTK_OBJECTP(x)) SCM_ERR("bad widget", x);
1750 return(SCM_LIST2(SCM_MKINUM(SGTK_WIDGET(x)->allocation.width),
1751 SCM_MKINUM(SGTK_WIDGET(x)->allocation.height)));
1752 }
1753
1754 /*E* (gtk-widget-get-width W) => INT */
sgtk_widget_get_width(SOBJ x)1755 SOBJ sgtk_widget_get_width(SOBJ x)
1756 {
1757 if (!SGTK_OBJECTP(x)) SCM_ERR("bad widget", x);
1758 return(SCM_MKINUM(SGTK_WIDGET(x)->allocation.width));
1759 }
1760 /*E* (gtk-widget-get-height W) => INT */
sgtk_widget_get_height(SOBJ x)1761 SOBJ sgtk_widget_get_height(SOBJ x)
1762 {
1763 if (!SGTK_OBJECTP(x)) SCM_ERR("bad widget", x);
1764 return(SCM_MKINUM(SGTK_WIDGET(x)->allocation.height));
1765 }
1766
1767 /*** get style gc */
1768 /*E* (gtk-widget-get-style-black-gc W) => GC */
sgtk_widget_get_style_black_gc(SOBJ x)1769 SOBJ sgtk_widget_get_style_black_gc(SOBJ x)
1770 {
1771 if (!SGTK_OBJECTP(x)) SCM_ERR("bad gtkobj", x);
1772 return(sgdk_GC_new(SGTK_WIDGET(x)->style->black_gc));
1773 }
1774
1775 /*E* (gtk-widget-get-style-white-gc W) => GC */
sgtk_widget_get_style_white_gc(SOBJ x)1776 SOBJ sgtk_widget_get_style_white_gc(SOBJ x)
1777 {
1778 if (!SGTK_OBJECTP(x)) SCM_ERR("bad gtkobj", x);
1779 return(sgdk_GC_new(SGTK_WIDGET(x)->style->white_gc));
1780 }
1781
1782 /*
1783 * (gtk-widget-get-style-gc wdraw :fg :prelight)
1784 * (gtk-widget-get-style-color wdraw :light :normal)
1785 * state-type: normal | active | prelight | selected | insensitive
1786 */
1787
1788 /*E* (gtk-widget-get-style-gc W FIELD TYPE) => GC */
1789 /*D* FIELD=[:fg|:bg|:light|:dark|:mid|:text|:base],
1790 * TYPE=[:normal|:active|:prelight|:selected|:insensitive],
1791 */
sgtk_widget_get_style_gc(SOBJ w,SOBJ f,SOBJ t)1792 SOBJ sgtk_widget_get_style_gc(SOBJ w, SOBJ f, SOBJ t)
1793 {
1794 char *fieldname;
1795 int typenr;
1796 GdkGC **gcp;
1797 GtkWidget *wp;
1798
1799 if (!SGTK_OBJECTP(w)) SCM_ERR("bad widget", w);
1800 if ((fieldname = scm_getstr(f)) == NULL) SCM_ERR("bad field", f);
1801
1802 typenr = sgtk_enumget("GtkStateType", t);
1803
1804 wp = SGTK_WIDGET(w);
1805
1806 if (streq(fieldname, "fg")) gcp = wp->style->fg_gc;
1807 else if (streq(fieldname, "bg")) gcp = wp->style->bg_gc;
1808 else if (streq(fieldname, "light")) gcp = wp->style->light_gc;
1809 else if (streq(fieldname, "dark")) gcp = wp->style->dark_gc;
1810 else if (streq(fieldname, "mid")) gcp = wp->style->mid_gc;
1811 else if (streq(fieldname, "text")) gcp = wp->style->text_gc;
1812 else if (streq(fieldname, "base")) gcp = wp->style->base_gc;
1813 else SCM_ERR("bad field name", f);
1814 return(sgdk_GC_new(gcp[typenr]));
1815 }
1816
1817 /*E* (gtk-widget-get-style-color W FIELD TYPE) => COLOR */
1818 /*D* FIELD=[:fg|:bg|:light|:dark|:mid|:text|:base],
1819 * TYPE=[:normal|:active|:prelight|:selected|:insensitive],
1820 */
sgtk_widget_get_style_color(SOBJ w,SOBJ f,SOBJ t)1821 SOBJ sgtk_widget_get_style_color(SOBJ w, SOBJ f, SOBJ t)
1822 {
1823 char *fieldname;
1824 int typenr;
1825 GdkColor *gcp;
1826 GtkWidget *wp;
1827
1828 if (!SGTK_OBJECTP(w)) SCM_ERR("bad widget", w);
1829 if ((fieldname = scm_getstr(f)) == NULL) SCM_ERR("bad field", f);
1830
1831 typenr = sgtk_enumget("GtkStateType", t);
1832
1833 wp = SGTK_WIDGET(w);
1834
1835 if (streq(fieldname, "fg")) gcp = wp->style->fg;
1836 else if (streq(fieldname, "bg")) gcp = wp->style->bg;
1837 else if (streq(fieldname, "light")) gcp = wp->style->light;
1838 else if (streq(fieldname, "dark")) gcp = wp->style->dark;
1839 else if (streq(fieldname, "mid")) gcp = wp->style->mid;
1840 else if (streq(fieldname, "text")) gcp = wp->style->text;
1841 else if (streq(fieldname, "base")) gcp = wp->style->base;
1842 else SCM_ERR("bad field name", f);
1843 return(sgdk_Color_new(gcp + typenr));
1844 }
1845
1846 /*** CLIST ***/
make_text_from_list(SOBJ l)1847 static char **make_text_from_list(SOBJ l)
1848 {
1849 char **text;
1850 int n, i;
1851
1852 if (SCM_ARRAYP(l)) {
1853 text = scm_must_alloc(SCM_ASIZE(l) * sizeof(char *));
1854 for (i = 0; i < SCM_ASIZE(l); i++) {
1855 text[i] = SCM_STRINGP(SCM_AREF(l, i)) ?
1856 SCM_STR_VALUE(SCM_AREF(l, i)) : NULL;
1857 }
1858
1859 } else if (SCM_PAIRP(l)) {
1860 if ((n = scm_list_length(l)) == -1) SCM_ERR("bad list", l);
1861 text = scm_must_alloc(n * sizeof(char *));
1862 for (i = 0; l; l=SCM_CDR(l), i++) {
1863 text[i] = SCM_STRINGP(SCM_CAR(l)) ?
1864 SCM_STR_VALUE(SCM_CAR(l)) :
1865 NULL;
1866 }
1867 } else {
1868 SCM_ERR("bad list | array", l);
1869 }
1870 return(text);
1871 }
1872
1873 /*E* (gtk-clist-append CLIST LIST|VECTOR) => ROW */
sgtk_clist_append(SOBJ cl,SOBJ l)1874 SOBJ sgtk_clist_append(SOBJ cl, SOBJ l)
1875 {
1876 GtkCList *clist = sgtk_get_Object(cl);
1877 char **text = make_text_from_list(l);
1878 int n = gtk_clist_append(clist, text);
1879 scm_free(text);
1880 return(SCM_MKINUM(n));
1881 }
1882
1883 /*E* (gtk-clist-prepend CLIST LIST|VECTOR) => ROW */
sgtk_clist_prepend(SOBJ cl,SOBJ l)1884 SOBJ sgtk_clist_prepend(SOBJ cl, SOBJ l)
1885 {
1886 GtkCList *clist = sgtk_get_Object(cl);
1887 char **text = make_text_from_list(l);
1888 int n = gtk_clist_prepend(clist, text);
1889 scm_free(text);
1890 return(SCM_MKINUM(n));
1891 }
1892
1893
1894
1895 /*** Initialization ***/
1896
scm_init_sgtk()1897 void scm_init_sgtk()
1898 {
1899 SOBJ_T_GdkFont = scm_add_type(&sgdk_Font_type_descr);
1900 SOBJ_T_GdkColor = scm_add_type(&sgdk_Color_type_descr);
1901 SOBJ_T_GdkEvent = scm_add_type(&sgdk_Event_type_descr);
1902 SOBJ_T_GdkWindow = scm_add_type(&sgdk_Window_type_descr);
1903 SOBJ_T_GdkGC = scm_add_type(&sgdk_GC_type_descr);
1904 SOBJ_T_GdkVisual = scm_add_type(&sgdk_Visual_type_descr);
1905 SOBJ_T_GdkColormap = scm_add_type(&sgdk_Colormap_type_descr);
1906 SOBJ_T_GdkDragContext = scm_add_type(&sgdk_DragContext_type_descr);
1907 SOBJ_T_GdkAtom = scm_add_type(&sgdk_Atom_type_descr);
1908 SOBJ_T_GdkCursor = scm_add_type(&sgdk_Cursor_type_descr);
1909
1910 SOBJ_T_GtkObject = scm_add_type(&sgtk_Object_type_descr);
1911 SOBJ_T_GtkAccelGroup = scm_add_type(&sgtk_AccelGroup_type_descr);
1912 SOBJ_T_GtkStyleHelper = scm_add_type(&sgtk_StyleHelper_type_descr);
1913 SOBJ_T_GtkStyle = scm_add_type(&sgtk_Style_type_descr);
1914 SOBJ_T_GtkCTreeNode = scm_add_type(&sgtk_CTreeNode_type_descr);
1915 SOBJ_T_GtkSelectionData=scm_add_type(&sgtk_SelectionData_type_descr);
1916
1917 #ifdef LIBGLADE_SUPPORT
1918 SOBJ_T_GLADE_XML = scm_add_type(&sglade_xml_type_descr);
1919
1920 scm_add_cprim("glade-xml-signal-connect", sglade_xml_signal_connect, 3);
1921
1922 #endif
1923
1924 scm_add_cprim("gtk-idle-add", sgtk_idle_add, 1);
1925 scm_add_cprim("gtk-timeout-add", sgtk_timeout_add, 2);
1926 scm_add_cprim("gtk-signal-connect", sgtk_signal_connect, 4);
1927 scm_add_cprim("gtk-enum-get", sgtk_enum_get, 2);
1928 scm_add_cprim("gtk-flags-get", sgtk_flags_get, 2);
1929
1930 #include "sgtk-typep.i"
1931
1932 scm_add_cprim("gdk-window-get-pointer", sgdk_window_get_pointer,1);
1933
1934 scm_add_cprim("gdk-event-window" , sgdk_event_window, 1);
1935 scm_add_cprim("gdk-event-motion-hint", sgtk_event_motion_hint, 1);
1936 scm_add_cprim("gdk-event-motion-x", sgtk_event_motion_x, 1);
1937 scm_add_cprim("gdk-event-motion-y", sgtk_event_motion_y, 1);
1938 scm_add_cprim("gdk-event-motion-state", sgtk_event_motion_state,1);
1939 scm_add_cprim("gdk-event-area-x", sgtk_event_area_x, 1);
1940 scm_add_cprim("gdk-event-area-y", sgtk_event_area_y, 1);
1941 scm_add_cprim("gdk-event-area-width", sgtk_event_area_width, 1);
1942 scm_add_cprim("gdk-event-area-height", sgtk_event_area_height, 1);
1943
1944 scm_add_cprim("gdk-color-parse-new", sgtk_color_parse_new, 1);
1945
1946 scm_add_cprim("gtk-text-get-hadj", sgtk_text_get_hadj, 1);
1947 scm_add_cprim("gtk-text-get-vadj", sgtk_text_get_vadj, 1);
1948
1949 scm_add_cprim("gtk-file-select", sgtk_file_select, 2);
1950
1951 scm_add_cprim("gtk-adjustment-set-all", sgtk_adjustment_set_all, 7);
1952 scm_add_cprim("gtk-adjustment-get", sgtk_adjustment_get, 1);
1953 scm_add_cprim("gtk-adjustment-get-value", sgtk_adjustment_get_value, 1);
1954
1955 scm_add_cprim("gtk-widget-get-window", sgtk_widget_get_window, 1);
1956 scm_add_cprim("gtk-widget-get-size", sgtk_widget_get_size, 1);
1957 scm_add_cprim("gtk-widget-get-width", sgtk_widget_get_width, 1);
1958 scm_add_cprim("gtk-widget-get-height", sgtk_widget_get_height, 1);
1959
1960 scm_add_cprim("gtk-widget-get-style-black-gc",
1961 sgtk_widget_get_style_black_gc, 1);
1962
1963 scm_add_cprim("gtk-widget-get-style-white-gc",
1964 sgtk_widget_get_style_white_gc, 1);
1965
1966 scm_add_cprim("gtk-widget-get-style-gc",
1967 sgtk_widget_get_style_gc, 3);
1968
1969 scm_add_cprim("gtk-widget-get-style-color",
1970 sgtk_widget_get_style_color, 3);
1971
1972 /*** clist ***/
1973 scm_add_cprim("gtk-clist-append", sgtk_clist_append, 2);
1974 scm_add_cprim("gtk-clist-prepend", sgtk_clist_prepend, 2);
1975
1976 sgtk_obj_cache = scm_mkhash(SCM_HASH_T_GEN);
1977 scm_gc_protect(&sgtk_obj_cache);
1978
1979 sgtk_func_hash = scm_mkhash(SCM_HASH_T_GEN);
1980 scm_gc_protect(&sgtk_func_hash);
1981
1982 scm_puts("; sgtk extension loaded...\n");
1983 }
1984