/* * Time-stamp: <1998-03-11 15:38:53 szi> * * Copyright (C) 1997, 1998 Marius Vollmer * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include #include #include #include #include /* Define this to enable some output during GC and other interesting actions. */ #undef DEBUG_PRINT /* Guile compatability stuff */ void scm_done_malloc (long size); SCM scm_internal_cwdr (scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data, SCM_STACKITEM *stack_start); void scm_puts (char *str, SCM port); #ifndef SCM_LIST1 #define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) #endif #ifndef SCM_LIST2 #define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) #endif #ifndef HAVE_SCM_REVERSE_X #define scm_reverse_x scm_list_reverse_x #endif /* Associating SCM values with Gtk pointers. We keep a hash table that can store a SCM value for an arbitray gpointer. This is used for the proxies of GtkObjects and the boxed types. */ static GHashTable *proxy_tab; static guint gpointer_hash (gpointer a) { return (guint)a; } static gint gpointer_compare (gpointer a, gpointer b) { return a == b; } static void enter_proxy (gpointer obj, SCM proxy) { if (proxy_tab == NULL) proxy_tab = g_hash_table_new ((GHashFunc)gpointer_hash, (GCompareFunc)gpointer_compare); g_hash_table_insert (proxy_tab, obj, (gpointer)proxy); } static SCM get_proxy (gpointer obj) { if (proxy_tab) { gpointer val = g_hash_table_lookup (proxy_tab, obj); return val? (SCM) val : SCM_BOOL_F; } return SCM_BOOL_F; } static void forget_proxy (gpointer obj) { g_hash_table_remove (proxy_tab, obj); } /* Storing additional info about a GtkType. Each GtkType has a unique sequence number. We use that to simply index an array of sgtk_type_info pointers. The array is grown dynamically when necessary. */ #define TYPE_INFO_INCR_MASK 0xFF static sgtk_type_info **type_info_tab; static guint n_type_info_tab = 0; static void enter_type_info (sgtk_type_info *info) { guint seqno = GTK_TYPE_SEQNO (info->type); if (seqno >= n_type_info_tab) { guint i, new_size = (seqno+TYPE_INFO_INCR_MASK)&(~TYPE_INFO_INCR_MASK); type_info_tab = (sgtk_type_info **) scm_must_realloc ((char *)type_info_tab, sizeof(sgtk_type_info*) * n_type_info_tab, sizeof(sgtk_type_info*) * new_size, "type info table"); for (i = n_type_info_tab; i < new_size; i++) type_info_tab[i] = NULL; n_type_info_tab = new_size; } type_info_tab[seqno] = info; } sgtk_type_info* sgtk_get_type_info (guint seqno) { if (seqno >= n_type_info_tab) return NULL; return type_info_tab[seqno]; } static sgtk_type_info* must_get_type_info (guint seqno) { sgtk_type_info *info = sgtk_get_type_info (seqno); if (info == NULL) abort (); return info; } typedef struct _type_infos { struct _type_infos *next; sgtk_type_info **infos; } type_infos; static type_infos *all_type_infos; void sgtk_register_type_infos (sgtk_type_info **infos) { type_infos *t; sgtk_init (); t = (type_infos *) scm_must_malloc (sizeof(type_infos), "gtk type infos"); t->infos = infos; t->next = all_type_infos; all_type_infos = t; } static int sgtk_fillin_type_info (sgtk_type_info *info) { if (info->type != GTK_TYPE_OBJECT && info->type == GTK_FUNDAMENTAL_TYPE (info->type) && info->type != GTK_TYPE_INVALID) { GtkType parent_type = info->type; info->type = gtk_type_from_name (info->name); if (info->type == GTK_TYPE_INVALID) { fprintf (stderr, "unknown type `%s'.\n", info->name); return 0; } if (GTK_FUNDAMENTAL_TYPE (info->type) != parent_type) { fprintf (stderr, "mismatch for type `%s'.\n", info->name); info->type = GTK_TYPE_INVALID; return 0; } enter_type_info (info); } return 1; } sgtk_type_info* sgtk_find_type_info (GtkType type) { sgtk_type_info *info; type_infos *infos; char *name; info = sgtk_get_type_info (GTK_TYPE_SEQNO(type)); if (info) return info; /* XXX - merge this with the GtkObject code. I don't have the brain right now to do it. */ name = gtk_type_name (type); for (infos = all_type_infos; infos; infos = infos->next) { sgtk_type_info **ip; for (ip = infos->infos; *ip; ip++) if (!strcmp ((*ip)->name, name)) { if (GTK_FUNDAMENTAL_TYPE (type) != (*ip)->type) { fprintf (stderr, "mismatch for type `%s'.\n", name); info->type = GTK_TYPE_INVALID; abort (); } (*ip)->type = type; enter_type_info (*ip); return *ip; } } /* XXX - should use the Gtk+ type introspection here instead of giving up. */ fprintf (stderr, "unknown type `%s'.\n", name); abort (); } /* GtkObjects. GtkObjects are wrapped with a smob. The smob of a GtkObject is called its proxy. The proxy and its GtkObject are strongly connected; that is, the GtkObject will stay around as long as the proxy is referenced from Scheme, and the proxy will not be collected as long as the GtkObject is used from outside of Scheme. The lifetime of GtkObjects is controlled by a reference count, while Scheme objects are managed by a tracing garbage collector (mark/sweep). These two techniques are made to cooperate like this: the pointer from the proxy to the GtkObject is reflected in the reference count of the GtkObject. All proxies are kept in a list and those that point to GtkObjects with a reference count greater than the number of `internal' references are marked during the marking phase of the tracing collector. An internal reference is one that goes from a GtkObject with a proxy to another GtkObject with a proxy. We can only find a subset of the true internal references (because Gtk does not yet cooperate), but this should be good enough. By using this combination of tracing and reference counting it is possible to break the cycle that is formed by the proxy pointing to the GtkObject and the GtkObject pointing back. It is straightforward to extend this to other kind of cycles that might occur. For example, when connecting a Scheme procedure as a signal handler, the procedure is very likely to have the GtkObject that it is connected to in its environment. This cycle can be broken by including the procedure in the set of Scheme objects that get marked when we are tracing GtkObjects with a reference count greater than 1. Therefore, each proxy contains a list of `protects' that are marked when the proxy itself is marked. In addition to this, there is also a global list of `protects' that is used for Scheme objects that are somewhere in Gtk land but not clearly associated with a particular GtkObject (like timeout callbacks). */ /* The CDR of a GtkObject smob points to one of these. PROTECTS is a Scheme list of all SCM values that need to be protected from the GC because they are in use by OBJ. PROTECTS includes the smob cell itself. NEXT and PREVP are used to chain all proxies together for the marking mentioned above. NEXT simply points to the next proxy struct and PREVP points to the pointer that points to us. */ typedef struct _sgtk_object_proxy { GtkObject *obj; SCM protects; int traced_refs; struct _sgtk_object_proxy *next; struct _sgtk_object_proxy **prevp; } sgtk_object_proxy; /* The list of all existing proxies. */ static sgtk_object_proxy *all_proxies = NULL; /* Analogous to the PROTECTS list of a proxy but for SCM values that are not associated with a particular GtkObject. */ static SCM global_protects; /* The smob for GtkObjects. */ static long tc16_gtkobj; #define GTKOBJP(x) (SCM_NIMP(x) && SCM_CAR(x) == tc16_gtkobj) #define GTKOBJ_PROXY(x) ((sgtk_object_proxy *)SCM_CDR(x)) static void mark_traced_ref (GtkWidget *obj, void *data) { SCM p = (SCM)get_proxy (obj); if (p != SCM_BOOL_F) { sgtk_object_proxy *proxy = GTKOBJ_PROXY (p); #ifdef DEBUG_PRINT fprintf (stderr, "marking trace %p %s\n", proxy->obj, gtk_type_name (GTK_OBJECT_TYPE (proxy->obj))); #endif scm_gc_mark (proxy->protects); } } static SCM gtkobj_mark (SCM obj) { sgtk_object_proxy *proxy = GTKOBJ_PROXY(obj); #ifdef DEBUG_PRINT fprintf (stderr, "marking %p %s\n", proxy->obj, gtk_type_name (GTK_OBJECT_TYPE (proxy->obj))); #endif SCM_SETGC8MARK (obj); if (GTK_IS_CONTAINER (proxy->obj)) gtk_container_foreach (GTK_CONTAINER(proxy->obj), mark_traced_ref, NULL); return proxy->protects; } static int gtkobj_print (SCM obj, SCM port, scm_print_state *pstate) { sgtk_object_proxy *proxy = GTKOBJ_PROXY (obj); GtkType tid = GTK_OBJECT_TYPE (proxy->obj); scm_puts ("#<", port); scm_puts (gtk_type_name (tid), port); scm_puts (" ", port); scm_intprint ((long)proxy->obj, 16, port); scm_puts (">", port); return 1; } static scm_sizet gtkobj_free (SCM obj) { sgtk_object_proxy *proxy = GTKOBJ_PROXY (obj); SCM p; #ifdef DEBUG_PRINT fprintf (stderr, "freeing %p %s\n", proxy->obj, gtk_type_name (GTK_OBJECT_TYPE (proxy->obj))); #endif forget_proxy (proxy->obj); gtk_object_unref (proxy->obj); if (*proxy->prevp = proxy->next) proxy->next->prevp = proxy->prevp; scm_must_free ((char *)proxy); return sizeof (sgtk_object_proxy); } struct scm_smobfuns gtkobj_smob = { gtkobj_mark, gtkobj_free, gtkobj_print, NULL }; /* Protect OBJ from being collected. When PROTECTOR is a GtkObject proxy, OBJ is only protected as long as GtkObject is live. */ SCM sgtk_protect (SCM protector, SCM obj) { if (GTKOBJP (protector)) { sgtk_object_proxy *proxy = GTKOBJ_PROXY(protector); proxy->protects = scm_cons (obj, proxy->protects); } else global_protects = scm_cons (obj, global_protects); return obj; } static void sgtk_unprotect_1 (SCM *prev, SCM obj) { SCM walk; for (walk = *prev; SCM_NIMP (walk) && SCM_CONSP (walk); walk = SCM_CDR (walk)) { if (SCM_CAR (walk) == obj) { *prev = SCM_CDR (walk); break; } else prev = SCM_CDRLOC (walk); } } /* XXX - performance improvement by searching only a single proxy->protects. */ void sgtk_unprotect (SCM obj) { sgtk_object_proxy *proxy; for (proxy = all_proxies; proxy; proxy = proxy->next) sgtk_unprotect_1 (&proxy->protects, obj); sgtk_unprotect_1 (&global_protects, obj); } /* Treating GtkObject proxies right during GC. We need to run custom code during the mark phase of the Scheme GC. We do this by creating a new smob type and allocating one actual smob of it. This smob is made permanent and thus its marking function is invoked for every GC. We hijack this function to do the tracing of all existing proxies as well. */ static long tc16_gtkobj_marker_hook; static void count_traced_ref (GtkWidget *obj, void *data) { SCM p = (SCM)get_proxy (obj); if (p != SCM_BOOL_F) { sgtk_object_proxy *proxy = GTKOBJ_PROXY (p); #ifdef DEBUG_PRINT fprintf (stderr, "counting %p %s\n", proxy->obj, gtk_type_name (GTK_OBJECT_TYPE (proxy->obj))); #endif proxy->traced_refs++; } } static SCM gtkobj_marker_hook (SCM obj) { sgtk_object_proxy *proxy; SCM_SETGC8MARK (obj); /* We do two passes here. The first pass counts how many references an object has from other objects that have a proxy. The second pass marks all objects that have more than this number of references. For the first pass to work, we need to enumerate all references that an object has to other objects. We can't do that precisely without help from Gtk+ itself. But luckily, *not* knowing about an `internal' reference is the conservative thing. Missing a reference will make it appear to us that an object has more `external' references to it than it really has, thus making us keep the proxy alive. Only when these `external' references form a cycle over some Scheme values, we loose. As a first approximation to the true set of references of a GtkObject, we just traverse its children with gtk_container_foreach. */ /* First pass. */ for (proxy = all_proxies; proxy; proxy = proxy->next) { GtkObject *obj = proxy->obj; if (GTK_IS_CONTAINER (obj)) gtk_container_foreach (GTK_CONTAINER(obj), count_traced_ref, NULL); } /* Second pass. */ for (proxy = all_proxies; proxy; proxy = proxy->next) { if (proxy->obj->ref_count > proxy->traced_refs + 1) { #ifdef DEBUG_PRINT fprintf (stderr, "hooking %p %s\n", proxy->obj, gtk_type_name (GTK_OBJECT_TYPE (proxy->obj))); #endif scm_gc_mark (proxy->protects); } proxy->traced_refs = 0; } return global_protects; } static int gtkobj_marker_hook_print (SCM obj, SCM port, scm_print_state *pstate) { scm_puts ("#", port); return 1; } struct scm_smobfuns gtkobj_marker_hook_smob = { gtkobj_marker_hook, NULL, gtkobj_marker_hook_print, NULL }; static void install_marker_hook () { SCM z; SCM_DEFER_INTS; SCM_NEWCELL (z); SCM_SETCAR (z, tc16_gtkobj_marker_hook); SCM_SETCDR (z, 0); SCM_ALLOW_INTS; scm_permanent_object (z); } /* Create a proxy for OBJ. */ static SCM make_gtkobj (GtkObject *obj) { sgtk_object_proxy *proxy; SCM z; proxy = (sgtk_object_proxy *)scm_must_malloc (sizeof(sgtk_object_proxy), "GtkObject proxy"); gtk_object_ref (obj); gtk_object_sink (obj); proxy->obj = obj; proxy->protects = SCM_EOL; proxy->traced_refs = 0; proxy->next = all_proxies; all_proxies = proxy; proxy->prevp = &all_proxies; if (proxy->next) proxy->next->prevp = &proxy->next; SCM_DEFER_INTS; SCM_NEWCELL (z); SCM_SETCAR (z, tc16_gtkobj); SCM_SETCDR (z, proxy); enter_proxy (obj, z); SCM_ALLOW_INTS; sgtk_protect (z, z); return z; } /* Return the proxy for OBJ if it already has one, else create a new one. When OBJ is NULL, return `#f'. */ SCM sgtk_wrap_gtkobj (GtkObject *obj) { SCM handle; if (obj == NULL) return SCM_BOOL_F; handle = get_proxy (obj); if (handle == SCM_BOOL_F) handle = make_gtkobj (obj); return handle; } int sgtk_is_a_gtkobj (guint type, SCM obj) { GtkObject *gobj; if (!(SCM_NIMP (obj) && GTKOBJP (obj))) return 0; return gtk_type_is_a (GTK_OBJECT_TYPE(GTKOBJ_PROXY(obj)->obj), type); } GtkObject* sgtk_get_gtkobj (SCM obj) { if (obj == SCM_BOOL_F) return NULL; else return GTKOBJ_PROXY(obj)->obj; } /* Enums. Enumerations are described by a `sgtk_enum_info' structure. That structure contains a list of all literals and their respective values. In Scheme, an enum element is represented by a symbol whose name is the literal. */ int sgtk_valid_enum (SCM obj, sgtk_enum_info *info) { int i; if (!SCM_NIMP (obj) || !SCM_SYMBOLP (obj)) return 0; for (i = 0; i < info->n_literals; i++) if (!strcmp (info->literals[i].name, SCM_CHARS (obj))) return 1; return 0; } SCM sgtk_enum2scm (gint val, sgtk_enum_info *info) { int i; for (i = 0; i < info->n_literals; i++) if (info->literals[i].value == val) return SCM_CAR (scm_intern0 (info->literals[i].name)); SCM_ASSERT (0, SCM_MAKINUM (val), SCM_ARG1, "enum->symbol"); return SCM_BOOL_F; } gint sgtk_scm2enum (SCM obj, sgtk_enum_info *info) { int i; for (i = 0; i < info->n_literals; i++) if (!strcmp (info->literals[i].name, SCM_CHARS (obj))) return info->literals[i].value; return -1; } /* Flags. Like enums, flags are described by a `sgtk_enum_info' structure. In Scheme, flags are represented by a list of symbols, one for each bit that is set in the flags value. */ int sgtk_valid_flags (SCM obj, sgtk_enum_info *info) { while (!SCM_NULLP (obj)) { int i, valid; SCM sym; if (SCM_IMP (obj) || !SCM_CONSP (obj)) return 0; sym = SCM_CAR (obj); if (SCM_IMP (sym) || !SCM_SYMBOLP (sym)) return 0; for (i = 0, valid = 0; i < info->n_literals; i++) if (!strcmp (info->literals[i].name, SCM_CHARS (sym))) { valid = 1; break; } if (!valid) return 0; obj = SCM_CDR (obj); } return 1; } SCM sgtk_flags2scm (gint val, sgtk_enum_info *info) { SCM ans = SCM_EOL; int i; for (i = 0; i < info->n_literals; i++) if (val & info->literals[i].value) { ans = scm_cons (SCM_CAR (scm_intern0 (info->literals[i].name)), ans); val &= ~info->literals[i].value; } return ans; } gint sgtk_scm2flags (SCM obj, sgtk_enum_info *info) { int ans = 0; while (!SCM_NULLP (obj)) { int i; SCM sym = SCM_CAR (obj); for (i = 0; i < info->n_literals; i++) if (!strcmp (info->literals[i].name, SCM_CHARS (sym))) { ans |= info->literals[i].value; break; } obj = SCM_CDR (obj); } return ans; } /* String enums. A string enum is like an enum, but the values are strings. The range of values can be extended, so anywhere a "string enum" value is accepted, we also accept a string (but not a symbol). */ int sgtk_valid_senum (SCM obj, sgtk_senum_info *info) { int i; if (! SCM_NIMP (obj)) return 0; if (SCM_STRINGP (obj)) return 1; if (! SCM_SYMBOLP (obj)) return 0; for (i = 0; i < info->n_literals; i++) if (! strcmp (info->literals[i].name, SCM_CHARS (obj))) return 1; return 0; } SCM sgtk_senum2scm (char *val, sgtk_senum_info *info) { int i; for (i = 0; i < info->n_literals; i++) if (! strcmp (info->literals[i].value, val)) return SCM_CAR (scm_intern0 (info->literals[i].name)); return scm_makfrom0str (val); } char * sgtk_scm2senum (SCM obj, sgtk_senum_info *info) { int i; if (SCM_STRINGP (obj)) { SCM_COERCE_SUBSTR (obj); return SCM_CHARS (obj); } for (i = 0; i < info->n_literals; i++) if (! strcmp (info->literals[i].name, SCM_CHARS (obj))) return info->literals[i].value; return NULL; } /* Boxed Values. */ static long tc16_boxed; #define BOXED_P(x) (SCM_NIMP(x) && (SCM_TYP16(x) == tc16_boxed)) #define BOXED_SEQNO(x) (((guint)SCM_CAR(x))>>16) #define BOXED_PTR(x) ((gpointer)SCM_CDR(x)) #define BOXED_INFO(x) ((sgtk_boxed_info*)must_get_type_info(BOXED_SEQNO(x))) static scm_sizet boxed_free (SCM obj) { sgtk_boxed_info *info = BOXED_INFO (obj); info->destroy (BOXED_PTR (obj)); return info->size; } static int boxed_print (SCM exp, SCM port, scm_print_state *pstate) { sgtk_boxed_info *info = BOXED_INFO (exp); scm_puts ("#<", port); scm_puts (info->header.name, port); scm_puts (" ", port); scm_intprint ((long)BOXED_PTR (exp), 16, port); scm_puts (">", port); return 1; } struct scm_smobfuns boxed_smob = { scm_mark0, boxed_free, boxed_print, NULL }; SCM sgtk_boxed2scm (gpointer ptr, sgtk_boxed_info *info, int copyp) { SCM z; if (ptr == NULL) return SCM_BOOL_F; if (!sgtk_fillin_type_info (&info->header)) return SCM_BOOL_F; SCM_DEFER_INTS; if (copyp) { ptr = info->copy (ptr); scm_done_malloc (info->size); } SCM_NEWCELL (z); if (GTK_TYPE_SEQNO(info->header.type) > 0xFFFF) abort (); SCM_SETCAR (z, tc16_boxed | (GTK_TYPE_SEQNO(info->header.type))<<16); SCM_SETCDR (z, ptr); SCM_ALLOW_INTS; return z; } void * sgtk_scm2boxed (SCM obj) { if (obj == SCM_BOOL_F) return NULL; return BOXED_PTR (obj); } int sgtk_valid_boxed (SCM obj, sgtk_boxed_info *info) { return (SCM_NIMP (obj) && BOXED_P (obj) && BOXED_INFO (obj) == info); } /* Floats. Only here to set things straight. */ int sgtk_valid_float (SCM obj) { return SCM_NUMBERP (obj); } SCM gh_double2scm (double); gfloat sgtk_scm2float (SCM obj) { return gh_scm2double (obj); } SCM sgtk_float2scm (gfloat f) { return gh_double2scm ((double)f); } int sgtk_valid_double (SCM obj) { return SCM_NUMBERP (obj); } SCM gh_double2scm (double); double sgtk_scm2double (SCM obj) { return gh_scm2double (obj); } SCM sgtk_double2scm (double f) { return gh_double2scm (f); } /* Composites. */ int sgtk_valid_composite (SCM obj, int (*predicate)(SCM)) { if (scm_ilength (obj) >= 0) { while (SCM_NIMP(obj) && SCM_CONSP(obj)) { if (!predicate (SCM_CAR(obj))) return 0; obj = SCM_CDR(obj); } return 1; } else if (SCM_NIMP(obj) && SCM_VECTORP(obj)) { int len = SCM_LENGTH (obj), i; SCM *elts = SCM_VELTS (obj); for (i = 0; i < len; i++) if (!predicate(elts[i])) return 0; return 1; } else return 0; } SCM sgtk_slist2scm (GSList *list, SCM (*toscm)(void*)) { SCM res, *tail = &res; while (list) { *tail = scm_cons (toscm (&list->data), *tail); tail = SCM_CDRLOC (*tail); list = list->next; } *tail = SCM_EOL; return res; } GSList* sgtk_scm2slist (SCM obj, void (*fromscm)(SCM, void*)) { GSList *res, **tail = &res; if (obj == SCM_EOL || (SCM_NIMP(obj) && SCM_CONSP(obj))) { while (SCM_NIMP(obj) && SCM_CONSP(obj)) { *tail = g_slist_alloc (); fromscm (SCM_CAR (obj), &(*tail)->data); obj = SCM_CDR(obj); tail = &(*tail)->next; } } else if (SCM_NIMP(obj) && SCM_VECTORP(obj)) { int len = SCM_LENGTH (obj), i; SCM *elts = SCM_VELTS (obj); for (i = 0; i < len; i++) { *tail = g_slist_alloc (); fromscm (elts[i], &(*tail)->data); tail = &(*tail)->next; } } (*tail)->next = NULL; return res; } sgtk_cvec sgtk_scm2cvec (SCM obj, void (*fromscm)(SCM, void*), size_t sz) { sgtk_cvec res; int i, len; char *ptr; if ((res.count = scm_ilength (obj)) >= 0) { res.vec = (void *)scm_must_malloc (res.count * sz, "scm2cvec"); for (i = 0, ptr = res.vec; i < res.count; i++, ptr += sz) { fromscm (SCM_CAR (obj), ptr); obj = SCM_CDR(obj); } } else if (SCM_NIMP(obj) && SCM_VECTORP(obj)) { SCM *elts = SCM_VELTS (obj); res.count = SCM_LENGTH (obj); res.vec = (void *)scm_must_malloc (res.count * sz, "scm2cvec"); for (i = 0, ptr = res.vec; i < res.count; i++, ptr += sz) fromscm (elts[i], ptr); } return res; } void sgtk_cvec_free (sgtk_cvec *cvec) { scm_must_free (cvec->vec); } /* converting between SCM and GtkArg */ SCM sgtk_arg2scm (GtkArg *a, int free_mem) { switch (GTK_FUNDAMENTAL_TYPE (a->type)) { case GTK_TYPE_NONE: return SCM_UNSPECIFIED; case GTK_TYPE_CHAR: return gh_char2scm (GTK_VALUE_CHAR(*a)); case GTK_TYPE_BOOL: return GTK_VALUE_BOOL(*a)? SCM_BOOL_T : SCM_BOOL_F; case GTK_TYPE_INT: return scm_long2num (GTK_VALUE_INT(*a)); case GTK_TYPE_UINT: return scm_ulong2num (GTK_VALUE_UINT(*a)); case GTK_TYPE_LONG: return scm_long2num (GTK_VALUE_LONG(*a)); case GTK_TYPE_ULONG: return scm_ulong2num (GTK_VALUE_ULONG(*a)); case GTK_TYPE_FLOAT: return sgtk_float2scm (GTK_VALUE_FLOAT(*a)); case GTK_TYPE_DOUBLE: return sgtk_double2scm (GTK_VALUE_DOUBLE(*a)); case GTK_TYPE_STRING: { SCM ret = scm_makfrom0str (GTK_VALUE_STRING(*a)); if (free_mem) g_free GTK_VALUE_STRING(*a); return ret; } case GTK_TYPE_ENUM: return sgtk_enum2scm (GTK_VALUE_FLAGS(*a), (sgtk_enum_info *)sgtk_find_type_info (a->type)); case GTK_TYPE_FLAGS: return sgtk_flags2scm (GTK_VALUE_FLAGS(*a), (sgtk_enum_info *)sgtk_find_type_info (a->type)); case GTK_TYPE_BOXED: return sgtk_boxed2scm (GTK_VALUE_BOXED(*a), (sgtk_boxed_info *)sgtk_find_type_info (a->type), TRUE); case GTK_TYPE_OBJECT: return sgtk_wrap_gtkobj (GTK_VALUE_OBJECT(*a)); default: fprintf (stderr, "illegal type %s in arg\n", gtk_type_name (a->type)); return SCM_BOOL_F; } } void sgtk_scm2arg (GtkArg *a, SCM obj, SCM protector) { switch (GTK_FUNDAMENTAL_TYPE (a->type)) { case GTK_TYPE_NONE: return; case GTK_TYPE_CHAR: GTK_VALUE_CHAR(*a) = gh_scm2char (obj); break; case GTK_TYPE_BOOL: GTK_VALUE_BOOL(*a) = SCM_NFALSEP (obj); break; case GTK_TYPE_INT: GTK_VALUE_INT(*a) = scm_num2long (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_UINT: GTK_VALUE_UINT(*a) = scm_num2ulong (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_LONG: GTK_VALUE_LONG(*a) = scm_num2long (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_ULONG: GTK_VALUE_ULONG(*a) = scm_num2ulong (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_FLOAT: GTK_VALUE_FLOAT(*a) = sgtk_scm2float (obj); break; case GTK_TYPE_DOUBLE: GTK_VALUE_DOUBLE(*a) = sgtk_scm2double (obj); break; case GTK_TYPE_STRING: SCM_ASSERT (SCM_NIMP(obj) && SCM_STRINGP(obj), obj, SCM_ARG1, "scm->gtk"); SCM_COERCE_SUBSTR (obj); GTK_VALUE_STRING(*a) = SCM_CHARS(obj); break; case GTK_TYPE_ENUM: GTK_VALUE_ENUM(*a) = sgtk_scm2enum (obj, (sgtk_enum_info *)sgtk_find_type_info (a->type)); break; case GTK_TYPE_FLAGS: GTK_VALUE_ENUM(*a) = sgtk_scm2flags (obj, (sgtk_enum_info *)sgtk_find_type_info (a->type)); break; case GTK_TYPE_BOXED: GTK_VALUE_BOXED(*a) = sgtk_scm2boxed (obj); break; case GTK_TYPE_CALLBACK: sgtk_protect (protector, obj); GTK_VALUE_CALLBACK(*a).marshal = sgtk_callback_marshal; GTK_VALUE_CALLBACK(*a).data = (gpointer)obj; GTK_VALUE_CALLBACK(*a).notify = sgtk_callback_destroy; break; case GTK_TYPE_OBJECT: SCM_ASSERT (sgtk_is_a_gtkobj (a->type, obj), obj, SCM_ARG1, "scm->gtk"); GTK_VALUE_OBJECT(*a) = sgtk_get_gtkobj (obj); break; default: fprintf (stderr, "unhandled arg type %s\n", gtk_type_name (a->type)); break; } } void sgtk_scm2ret (GtkArg *a, SCM obj) { switch (GTK_FUNDAMENTAL_TYPE (a->type)) { case GTK_TYPE_NONE: return; case GTK_TYPE_CHAR: *GTK_RETLOC_CHAR(*a) = gh_scm2char (obj); break; case GTK_TYPE_BOOL: *GTK_RETLOC_BOOL(*a) = SCM_NFALSEP (obj); break; case GTK_TYPE_INT: *GTK_RETLOC_INT(*a) = scm_num2long (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_UINT: *GTK_RETLOC_UINT(*a) = scm_num2ulong (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_LONG: *GTK_RETLOC_LONG(*a) = scm_num2long (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_ULONG: *GTK_RETLOC_ULONG(*a) = scm_num2ulong (obj, (char*)SCM_ARG1, "scm->gtk"); break; case GTK_TYPE_FLOAT: *GTK_RETLOC_FLOAT(*a) = sgtk_scm2float (obj); break; case GTK_TYPE_DOUBLE: *GTK_RETLOC_DOUBLE(*a) = sgtk_scm2double (obj); break; case GTK_TYPE_STRING: SCM_ASSERT (SCM_NIMP(obj) && SCM_STRINGP(obj), obj, SCM_ARG1, "scm->gtk"); SCM_COERCE_SUBSTR (obj); GTK_VALUE_STRING(*a) = g_strdup (SCM_CHARS(obj)); break; case GTK_TYPE_ENUM: *GTK_RETLOC_ENUM(*a) = sgtk_scm2enum (obj, (sgtk_enum_info *)sgtk_find_type_info (a->type)); break; case GTK_TYPE_FLAGS: *GTK_RETLOC_ENUM(*a) = sgtk_scm2flags (obj, (sgtk_enum_info *)sgtk_find_type_info (a->type)); break; case GTK_TYPE_BOXED: *GTK_RETLOC_BOXED(*a) = sgtk_scm2boxed (obj); break; case GTK_TYPE_OBJECT: SCM_ASSERT (sgtk_is_a_gtkobj (a->type, obj), obj, SCM_ARG1, "scm->gtk"); *GTK_RETLOC_OBJECT(*a) = sgtk_get_gtkobj (obj); break; default: fprintf (stderr, "unhandled return type %s\n", gtk_type_name (a->type)); break; } } /* Callbacks. Callbacks are executed within a new dynamic root. That means that the flow of control can't leave them without Gtk noticing. Throws are catched and briefly reported. Calls to continuations that have been made outside the dynamic root can not be activated. Callbacks are invoked with whatever arguments that are specified by the Gtk documentation. They do not, however, receive the GtkObject that has initiated the callback. When callback_trampoline is non-#f, we treat it as a procedure and call it as (trampoline proc args) PROC is the real callback procedure and ARGS is the list of arguments that should be passed to it. */ static SCM callback_trampoline; /* The SCM_PROC for gtk-callback-trampoline is in gtk-support.c to have it be snarfed for sgtk_init_support */ SCM sgtk_callback_trampoline (SCM new) { SCM old = SCM_CAR (callback_trampoline); if (new != SCM_UNDEFINED) SCM_SETCAR (callback_trampoline, new); return old; } struct callback_info { SCM proc; gint n_args; GtkArg *args; }; static SCM inner_callback_marshal (void *data) { struct callback_info *info = (struct callback_info *)data; int i; SCM args = SCM_EOL, ans; for (i = info->n_args-1; i >= 0; i--) args = scm_cons (sgtk_arg2scm (info->args+i, 0), args); if (SCM_FALSEP (SCM_CAR(callback_trampoline))) ans = scm_apply (info->proc, args, SCM_EOL); else ans = scm_apply (SCM_CAR(callback_trampoline), scm_cons2 (info->proc, args, SCM_EOL), SCM_EOL); if (info->args[info->n_args].type != GTK_TYPE_NONE) sgtk_scm2ret (info->args+info->n_args, ans); return SCM_UNSPECIFIED; } /* Be carefull when this macro is true. scm_gc_heap_lock is set during gc. */ #define SCM_GC_P (scm_gc_heap_lock) void sgtk_callback_marshal (GtkObject *obj, gpointer data, guint n_args, GtkArg *args) { SCM_STACKITEM stack_item; struct callback_info info; if (SCM_GC_P) { /* This should only happen for the "destroy" signal and is then harmless. */ fprintf (stderr, "callback ignored during GC!\n"); return; } info.proc = (SCM) data; info.n_args = n_args; info.args = args; scm_internal_cwdr (inner_callback_marshal, &info, scm_handle_by_message_noexit, "gtk", &stack_item); } void sgtk_callback_destroy (gpointer data) { sgtk_unprotect ((SCM)data); } /* Type conversions */ extern sgtk_boxed_info sgtk_gdk_color_info; SCM sgtk_color_conversion (SCM color) { SCM orig_color = color; if (SCM_NIMP (color) && SCM_STRINGP (color)) { GdkColor colstruct; GdkColormap *colmap; SCM_COERCE_SUBSTR (color); SCM_DEFER_INTS; if (!gdk_color_parse (SCM_CHARS (color), &colstruct)) { SCM_ALLOW_INTS; scm_misc_error ("string->color", "no such color: %S", scm_cons (orig_color, SCM_EOL)); } colmap = gtk_widget_peek_colormap (); if (!gdk_color_alloc (colmap, &colstruct)) { SCM_ALLOW_INTS; scm_misc_error ("string->color", "can't allocate color: %S", scm_cons (orig_color, SCM_EOL)); } SCM_ALLOW_INTS; return sgtk_boxed2scm (&colstruct, &sgtk_gdk_color_info, 1); } return color; } extern SCM sgtk_gdk_font_load (SCM font); SCM sgtk_font_conversion (SCM font) { SCM orig_font = font; if (SCM_NIMP (font) && SCM_STRINGP (font)) { SCM_COERCE_SUBSTR (font); font = sgtk_gdk_font_load (font); if (font == SCM_BOOL_F) scm_misc_error ("string->font", "no such font: %S", scm_cons (orig_font, SCM_EOL)); } return font; } SCM sgtk_string_conversion (SCM str) { if (SCM_NIMP (str) && SCM_STRINGP (str)) SCM_COERCE_SUBSTR (str); return str; } /* Support for gtk_object_new, gtk_object_set, ... */ /* The SCM_PROC for the exported functions is in gtk-support.c to have it be snarfed for sgtk_init_gtk_support. */ sgtk_object_info *sgtk_find_object_info (char *name); sgtk_object_info * sgtk_find_object_info_from_type (GtkType type) { sgtk_object_info *info; info = (sgtk_object_info *)sgtk_get_type_info (GTK_TYPE_SEQNO(type)); if (info) return info; return sgtk_find_object_info (gtk_type_name (type)); } sgtk_object_info * sgtk_find_object_info (char *name) { GtkType type, parent; sgtk_object_info *info; type_infos *infos; int i; type = gtk_type_from_name (name); if (type != GTK_TYPE_INVALID) { info = (sgtk_object_info *)sgtk_get_type_info (GTK_TYPE_SEQNO(type)); if (info) return info; } for (infos = all_type_infos; infos; infos = infos->next) { sgtk_type_info **ip; for (ip = infos->infos; *ip; ip++) if (!strcmp ((*ip)->name, name)) { if (GTK_FUNDAMENTAL_TYPE((*ip)->type) != GTK_TYPE_OBJECT) return NULL; info = (sgtk_object_info *)*ip; info->header.type = info->init_func (); enter_type_info ((sgtk_type_info*)info); gtk_type_class (info->header.type); info->args = gtk_object_query_args (info->header.type, &info->args_flags, &info->n_args); info->args_short_names = (char **)scm_must_malloc (info->n_args*(sizeof(char*)), "args short names"); for (i = 0; i < info->n_args; i++) { char *l = info->args[i].name; char *d = strchr (l, ':'); if (d == NULL || d[1] != ':') { fprintf (stderr, "`%s' has no class part.\n", l); info->args_short_names[i] = l; } else info->args_short_names[i] = d+2; } parent = gtk_type_parent (info->header.type); if (parent != GTK_TYPE_INVALID) info->parent = sgtk_find_object_info_from_type (parent); else info->parent = NULL; return info; } } return NULL; } static char* xstrndup (char *str, int n) { char *dup; if (str == NULL) return NULL; dup = scm_must_malloc (n+1, "xstrndup"); strncpy (dup, str, n); dup[n] = '\0'; return dup; } static void sgtk_find_arg_info (GtkArg *arg, sgtk_object_info *info, char *name) { /* XXX - handle signal handlers. Do not use '::', use '.' instead. */ char *d = strchr (name, ':'); if (d && d[1] == ':') { /* A long name. Find the object_info for the class part. */ int len = d-name; while (info) { if (info->header.name[len] == '\0' && !strncmp (info->header.name, name, len)) break; info = info->parent; } name = d+2; } #ifdef DEBUG_PRINT fprintf (stderr, "searching short `%s'\n", name); #endif while (info) { int i; for (i = 0; i < info->n_args; i++) { #ifdef DEBUG_PRINT fprintf (stderr, " on %s\n", info->args[i].name); #endif if (!strcmp (info->args_short_names[i], name)) { *arg = info->args[i]; return; } } info = info->parent; } arg->type = GTK_TYPE_INVALID; return; } GtkArg* sgtk_build_args (sgtk_object_info *info, int *n_argsp, SCM scm_args, SCM protector) { int i, n_args = *n_argsp; GtkArg *args; char *name; SCM kw, val; args = g_new0 (GtkArg, n_args); for (i = 0; i < n_args; i++) { skip: kw = SCM_CAR (scm_args); val = SCM_CADR (scm_args); scm_args = SCM_CDDR (scm_args); if (SCM_NIMP (kw) && SCM_SYMBOLP (kw)) name = SCM_CHARS(kw); else if (SCM_NIMP (kw) && SCM_KEYWORDP (kw)) name = SCM_CHARS(SCM_KEYWORDSYM(kw))+1; else { fprintf (stderr, "bad keyword\n"); n_args -= 1; i -= 1; continue; } sgtk_find_arg_info (&args[i], info, name); if (args[i].type == GTK_TYPE_INVALID) { fprintf (stderr, "no such arg for type `%s': %s\n", info->header.name, name); n_args -= 1; i -= 1; continue; } /* XXX - leak when scm2arg throws */ sgtk_scm2arg (&args[i], val, protector); } *n_argsp = n_args; return args; } SCM sgtk_gtk_object_new (SCM type_sym, SCM scm_args) { int n_args; sgtk_object_info *info; GtkArg *args; GtkObject *obj; SCM scm_obj; SCM_ASSERT (SCM_NIMP(type_sym) && SCM_SYMBOLP(type_sym), type_sym, SCM_ARG1, "gtk-object-new"); n_args = scm_ilength (scm_args); SCM_ASSERT (n_args >= 0 && (n_args%2) == 0, scm_args, SCM_ARG2, "gtk-object-new"); n_args = n_args/2; info = sgtk_find_object_info (SCM_CHARS(type_sym)); SCM_ASSERT (info != NULL, type_sym, SCM_ARG1, "gtk-object-new"); SCM_DEFER_INTS; obj = gtk_object_new (info->header.type, NULL); scm_obj = sgtk_wrap_gtkobj (obj); args = sgtk_build_args (info, &n_args, scm_args, scm_obj); gtk_object_setv (obj, n_args, args); g_free (args); SCM_ALLOW_INTS; return scm_obj; } SCM sgtk_gtk_object_set (SCM scm_obj, SCM scm_args) { int n_args; sgtk_object_info *info; GtkArg *args; GtkObject *obj; SCM_ASSERT (GTKOBJP(scm_obj), scm_obj, SCM_ARG1, "gtk-object-set"); n_args = scm_ilength (scm_args); SCM_ASSERT (n_args >= 0 && (n_args%2) == 0, scm_args, SCM_ARG2, "gtk-object-set"); n_args = n_args/2; obj = GTKOBJ_PROXY(scm_obj)->obj; info = sgtk_find_object_info_from_type (GTK_OBJECT_TYPE(obj)); SCM_ASSERT (info != NULL, scm_obj, SCM_ARG1, "gtk-object-set"); SCM_DEFER_INTS; args = sgtk_build_args (info, &n_args, scm_args, scm_obj); gtk_object_setv (obj, n_args, args); g_free (args); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } SCM sgtk_gtk_object_get (SCM scm_obj, SCM argsym) { GtkObject *obj; sgtk_object_info *info; char *name; GtkArg arg; SCM_ASSERT (GTKOBJP(scm_obj), scm_obj, SCM_ARG1, "gtk-object-get"); SCM_ASSERT (SCM_NIMP(argsym) && (SCM_KEYWORDP(argsym) || SCM_SYMBOLP(argsym)), argsym, SCM_ARG2, "gtk-object-get"); obj = GTKOBJ_PROXY(scm_obj)->obj; info = sgtk_find_object_info_from_type (GTK_OBJECT_TYPE(obj)); SCM_ASSERT (info != NULL, scm_obj, SCM_ARG1, "gtk-object-get"); if (SCM_SYMBOLP(argsym)) name = SCM_CHARS(argsym); else name = SCM_CHARS(SCM_KEYWORDSYM(argsym))+1; sgtk_find_arg_info (&arg, info, name); SCM_DEFER_INTS; if (arg.type != GTK_TYPE_INVALID) gtk_object_getv (obj, 1, &arg); SCM_ALLOW_INTS; if (arg.type == GTK_TYPE_INVALID) return SCM_BOOL_F; else return sgtk_arg2scm (&arg, 1); } /* Initialization */ static int standalone_p = 1; void sgtk_set_standalone (int flag) { standalone_p = flag; } int sgtk_is_standalone () { return standalone_p; } SCM sgtk_standalone_p () { return standalone_p? SCM_BOOL_T : SCM_BOOL_F; } void sgtk_register_glue (char *name, void (*func)(void)) { static char modprefix[] = "gtk %static-initfuncs% "; char *full_name; full_name = malloc (strlen (name) + sizeof (modprefix) + 1); if (full_name == NULL) return; strcpy (full_name, modprefix); strcat (full_name, name); scm_register_module_xxx (full_name, func); } SCM_SYMBOL (sym_top_repl, "top-repl"); SCM_SYMBOL (sym_quit, "quit"); SCM_SYMBOL (sym_use_modules, "use-modules"); SCM_SYMBOL (sym_gtk, "gtk"); SCM_SYMBOL (sym_gtk_repl, "gtk-repl"); static void sgtk_init_substrate (void) { tc16_gtkobj_marker_hook = scm_newsmob (>kobj_marker_hook_smob); tc16_gtkobj = scm_newsmob (>kobj_smob); tc16_boxed = scm_newsmob (&boxed_smob); global_protects = SCM_EOL; install_marker_hook (); callback_trampoline = scm_permanent_object (scm_cons (SCM_BOOL_F, SCM_EOL)); #ifndef SCM_MAGIC_SNARFER #ifndef MKDEP #include "guile-gtk.x" #endif /* MKDEP */ #endif /* SCM_MAGIC_SNARFER */ } static int sgtk_inited = 0; void sgtk_init_with_args (int *argcp, char ***argvp) { if (sgtk_inited) return; /* XXX - Initialize Gtk only once. We assume that Gtk has already been initialized when Gdk has. That is not completely correct, but the best I can do. */ if (gdk_display == NULL) gtk_init (argcp, argvp); sgtk_init_substrate (); sgtk_inited = 1; } static char* xstrdup (char *str) { if (str) { char *newstr = scm_must_malloc (strlen(str)+1, "strdup"); strcpy (newstr, str); return newstr; } else return NULL; } static void make_argv (SCM list, int *argc, char ***argv) { static char *argv_storage[1] = { "guile-gtk" }; int c = scm_ilength (list), i; char **v; *argv = argv_storage; *argc = 1; if (c < 0) return; v = (char **)scm_must_malloc ((c+1) * sizeof(char**), "make-argv"); for (i = 0; i < c; i++, list = SCM_CDR (list)) { if (SCM_IMP (SCM_CAR (list)) || SCM_NSTRINGP (SCM_CAR (list))) { scm_must_free ((char *)v); return; } v[i] = xstrdup (SCM_CHARS (SCM_CAR (list))); } v[c] = NULL; *argv = v; *argc = c; } void sgtk_init () { int argc; char **argv; make_argv (scm_program_arguments (), &argc, &argv); sgtk_init_with_args (&argc, &argv); scm_set_program_arguments (argc, argv, NULL); } static SCM hack_compiled_switches (SCM script) { SCM last_action; script = scm_reverse_x (script, SCM_UNDEFINED); last_action = SCM_CAR (script); SCM_SETCAR (script, SCM_LIST2 (sym_use_modules, SCM_LIST2 (sym_gtk, sym_gtk))); if (SCM_CAR (last_action) == sym_top_repl) { script = scm_cons (SCM_LIST1 (sym_gtk_repl), script); sgtk_set_standalone (0); } else if (SCM_CAR (last_action) != sym_quit) { fprintf (stderr, "guile-gtk: unknown action in startup script\n"); scm_display (last_action, SCM_UNDEFINED); scm_newline (SCM_UNDEFINED); exit (1); } return scm_reverse_x (script, SCM_UNDEFINED); } void sgtk_shell (int argc, char **argv) { SCM script; sgtk_init_with_args (&argc, &argv); /* If present, add SCSH-style meta-arguments from the top of the script file to the argument vector. See the SCSH manual: "The meta argument" for more details. */ { char **new_argv = scm_get_meta_args (argc, argv); if (new_argv) { argv = new_argv; argc = scm_count_argv (new_argv); } } script = hack_compiled_switches (scm_compile_shell_switches (argc, argv)); scm_eval_x (script); exit (0); }