extern sgtk_boxed_info sgtk_gdk_colormap_info; extern sgtk_boxed_info sgtk_gdk_cursor_info; extern sgtk_boxed_info sgtk_gdk_visual_info; #define SGTK_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object \ (scm_make_keyword_from_dash_symbol \ (scm_str2symbol ("-" scheme_name)))) SGTK_KEYWORD (kw_colormap, "colormap"); SGTK_KEYWORD (kw_cursor, "cursor"); SGTK_KEYWORD (kw_override_redirect, "override-redirect"); SGTK_KEYWORD (kw_title, "title"); SGTK_KEYWORD (kw_visual, "visual"); SGTK_KEYWORD (kw_wmclass, "wmclass"); SGTK_KEYWORD (kw_x, "x"); SGTK_KEYWORD (kw_y, "y"); /* The Gtk documentation doesn't seem to say whether NULL is allowed in the various fields of GdkWindowAttr. The code looks like it's probably fine for the cursor, but not for the visual. Let's insist on actual objects and strings for now. */ GdkWindow * gdk_window_new_interp (GdkWindow *parent, int width, int height, GdkEventMask event_mask, GdkWindowClass window_class, GdkWindowType window_type, SCM rest) #define FUNC_NAME "gdk-window-new" { GdkWindowAttr attr; gint mask; GdkWindow *w; SCM key, val; unsigned long argnum; attr.event_mask = event_mask; attr.width = width; attr.height = height; attr.wclass = window_class; attr.window_type = window_type; mask = 0; argnum = 6; for (;;) { if (! SCM_CONSP (rest)) break; key = SCM_CAR (rest); rest = SCM_CDR (rest); if (! SCM_CONSP (rest)) scm_misc_error (FUNC_NAME, "missing argument to keyword ~A", scm_list_1 (key)); argnum += 2; val = SCM_CAR (rest); rest = SCM_CDR (rest); if (SCM_EQ_P (key, kw_colormap)) { SCM_ASSERT (sgtk_valid_boxed (val, &sgtk_gdk_colormap_info), val, argnum, FUNC_NAME); attr.colormap = (GdkColormap*) sgtk_scm2boxed (val); mask |= GDK_WA_COLORMAP; } else if (SCM_EQ_P (key, kw_cursor)) { SCM_ASSERT (sgtk_valid_boxed (val, &sgtk_gdk_cursor_info), val, argnum, FUNC_NAME); attr.cursor = (GdkCursor*) sgtk_scm2boxed (val); mask |= GDK_WA_CURSOR; } else if (SCM_EQ_P (key, kw_override_redirect)) { attr.override_redirect = ! SCM_FALSEP (val); mask |= GDK_WA_NOREDIR; } else if (SCM_EQ_P (key, kw_title)) { SCM_VALIDATE_STRING (argnum, val); attr.title = SCM_STRING_CHARS (val); mask |= GDK_WA_TITLE; } else if (SCM_EQ_P (key, kw_visual)) { SCM_ASSERT (sgtk_valid_boxed (val, &sgtk_gdk_visual_info), val, argnum, FUNC_NAME); attr.visual = (GdkVisual*) sgtk_scm2boxed (val); mask |= GDK_WA_VISUAL; } else if (SCM_EQ_P (key, kw_wmclass)) { SCM val2; if (! SCM_CONSP (rest)) scm_misc_error (FUNC_NAME, "missing second argument to keyword ~A", scm_list_1 (key)); val2 = SCM_CAR (rest); rest = SCM_CDR (rest); SCM_VALIDATE_STRING (argnum, val); argnum++; SCM_VALIDATE_STRING (argnum, val2); attr.wmclass_name = SCM_STRING_CHARS (val); attr.wmclass_class = SCM_STRING_CHARS (val); mask |= GDK_WA_WMCLASS; } else if (SCM_EQ_P (key, kw_x)) { attr.x = scm_num2short (val, argnum, FUNC_NAME); mask |= GDK_WA_X; } else if (SCM_EQ_P (key, kw_y)) { attr.y = scm_num2short (val, argnum, FUNC_NAME); mask |= GDK_WA_Y; } else scm_misc_error (FUNC_NAME, "unknown keyword ~A", scm_list_1 (key)); } w = gdk_window_new (parent, &attr, mask); /* ensure title string and boxed types are kept alive */ scm_remember_upto_here (rest); return w; }