* for-each-pkg in /home/rotty/src/guile-gnome-platform * atk: git 'diff' 'HEAD' * cairo: git 'diff' 'HEAD' * corba: git 'diff' 'HEAD' diff --git a/gnome/corba/guile-gnome-corba-generic.c b/gnome/corba/guile-gnome-corba-generic.c index 9515e6b..fe3418b 100644 --- a/gnome/corba/guile-gnome-corba-generic.c +++ b/gnome/corba/guile-gnome-corba-generic.c @@ -68,7 +68,7 @@ guile_corba_generic_make_type_name (const gchar *StudlyCaps) "gtype-name->class-name")); } - ret = scm_call_1 (de_studly_capsify, scm_makfrom0str (StudlyCaps)); + ret = scm_call_1 (de_studly_capsify, scm_from_locale_string (StudlyCaps)); return scm_to_locale_string (scm_symbol_to_string (ret)); } diff --git a/gnome/corba/guile-gnome-corba-primitives.c b/gnome/corba/guile-gnome-corba-primitives.c index 0b63ff3..209cab1 100644 --- a/gnome/corba/guile-gnome-corba-primitives.c +++ b/gnome/corba/guile-gnome-corba-primitives.c @@ -89,8 +89,8 @@ make_scm_module_name (const gchar *module_name) parts = g_strsplit (module_name, ":", 0); for (ptr = parts; *ptr; ptr++) - scm_name = scm_append_x (SCM_LIST2 (scm_name, SCM_LIST1 ( - scm_str2symbol (*ptr)))); + scm_name = scm_append_x (scm_list_2 (scm_name, scm_list_1 ( + scm_from_locale_symbol (*ptr)))); g_strfreev (parts); return scm_name; @@ -115,32 +115,32 @@ scm_c_corba_handle_exception (CORBA_Environment *ev) { SCM name; - name = scm_mem2string (ev->_id, strlen (ev->_id)); + name = scm_from_locale_stringn (ev->_id, strlen (ev->_id)); if (ev->_major == CORBA_SYSTEM_EXCEPTION) { CORBA_SystemException *se = CORBA_exception_value (ev); SCM minor, completed; - minor = scm_long2num (se->minor);; + minor = scm_from_long (se->minor);; switch (se->completed) { case CORBA_COMPLETED_YES: - completed = scm_str2symbol ("completed"); + completed = scm_from_locale_symbol ("completed"); break; case CORBA_COMPLETED_NO: - completed = scm_str2symbol ("not-completed"); + completed = scm_from_locale_symbol ("not-completed"); break; default: - completed = scm_str2symbol ("maybe-completed"); + completed = scm_from_locale_symbol ("maybe-completed"); break; } CORBA_exception_free (ev); scm_ithrow (scm_sym_corba_system_exception, - SCM_LIST3 (name, minor, completed), 1); + scm_list_3 (name, minor, completed), 1); } else { CORBA_exception_free (ev); - scm_ithrow (scm_sym_corba_user_exception, SCM_LIST1 (name), 1); + scm_ithrow (scm_sym_corba_user_exception, scm_list_1 (name), 1); } } @@ -218,14 +218,14 @@ case CORBA_tk_ ## k: \ retval = ## f (*(CORBA_ ## t *) value); \ break; - _HANDLE_BASIC_VALUE (short, short, scm_short2num); - _HANDLE_BASIC_VALUE (long, long, scm_long2num); - _HANDLE_BASIC_VALUE (ushort, unsigned_short, scm_int2num); - _HANDLE_BASIC_VALUE (ulong, unsigned_long, scm_ulong2num); + _HANDLE_BASIC_VALUE (short, short, scm_from_short); + _HANDLE_BASIC_VALUE (long, long, scm_from_long); + _HANDLE_BASIC_VALUE (ushort, unsigned_short, scm_from_int); + _HANDLE_BASIC_VALUE (ulong, unsigned_long, scm_from_ulong); _HANDLE_BASIC_VALUE (longlong, long_long, scm_long_long2num); _HANDLE_BASIC_VALUE (ulonglong, unsigned_long_long, scm_long_long2num); - _HANDLE_BASIC_VALUE (float, float, scm_float2num); - _HANDLE_BASIC_VALUE (double, double, scm_double2num); + _HANDLE_BASIC_VALUE (float, float, scm_from_double); + _HANDLE_BASIC_VALUE (double, double, scm_from_double); #undef _HANDLE_BASIC_VALUE } @@ -320,7 +320,7 @@ SCM_DEFINE (scm_corba_primitive_make_poa_instance, "corba-primitive-make-poa-ins SCM_NEWSMOB (smob, scm_tc16_guile_portable_server_servant, servant); - object = scm_make (SCM_LIST1 (class)); + object = scm_make (scm_list_1 (class)); scm_slot_set_x (object, scm_sym_servant, smob); gservant->this = object; @@ -338,7 +338,7 @@ repo_id_to_symbol (const gchar *format, const gchar *repo_id) SCM retval; new_repo_id = guile_corba_generic_repo_id_to_name (format, repo_id); - retval = scm_mem2symbol (new_repo_id, strlen (new_repo_id)); + retval = scm_from_locale_symboln (new_repo_id, strlen (new_repo_id)); g_free (new_repo_id); return retval; } @@ -414,7 +414,7 @@ scm_c_generic_skel_func (PortableServer_ServantBase *servant, imethod = (ORBit_IMethod *) SCM_SMOB_DATA (scm_c_vector_ref (poa_vector, 1)); generic = scm_c_vector_ref (poa_vector, 3); - args = SCM_LIST1 (gservant->this); + args = scm_list_1 (gservant->this); length = imethod->arguments._length; if (length) length--; @@ -425,7 +425,7 @@ scm_c_generic_skel_func (PortableServer_ServantBase *servant, SCM value; value = scm_c_corba_demarshal_any (&any); - args = scm_append_x (SCM_LIST2 (args, SCM_LIST1 (value))); + args = scm_append_x (scm_list_2 (args, scm_list_1 (value))); } func = scm_compute_applicable_methods (generic, args, scm_ilength (args), 1); @@ -541,10 +541,10 @@ guile_corba_sys_register_interface (ORBit_IInterface *iinterface) SCM_NEWSMOB (iinterface_smob, scm_tc16_guile_corba_interface, interface); poa_meta_class = scm_class_portable_server_servant_base; - poa_parent_classes = SCM_LIST1 (poa_meta_class); + poa_parent_classes = scm_list_1 (poa_meta_class); stub_meta_class = scm_class_corba_object; - stub_parent_classes = SCM_LIST1 (stub_meta_class); + stub_parent_classes = scm_list_1 (stub_meta_class); for (i = 0; i < length; i++) { GuileCorbaInterface *base_interface; @@ -561,10 +561,10 @@ guile_corba_sys_register_interface (ORBit_IInterface *iinterface) interface->vepv [i+1] = (PortableServer_ServantBase__epv *) base_interface->epv; poa_meta_class = base_interface->poa_class; - poa_parent_classes = scm_append_x (SCM_LIST2 (SCM_LIST1 (poa_meta_class), poa_parent_classes)); + poa_parent_classes = scm_append_x (scm_list_2 (scm_list_1 (poa_meta_class), poa_parent_classes)); stub_meta_class = base_interface->stub_class; - stub_parent_classes = scm_append_x (SCM_LIST2 (SCM_LIST1 (stub_meta_class), stub_parent_classes)); + stub_parent_classes = scm_append_x (scm_list_2 (scm_list_1 (stub_meta_class), stub_parent_classes)); for (j = 0; j < base_interface->iinterface->methods._length; j++) { ORBit_IMethod *imethod = &base_interface->iinterface->methods._buffer [j]; @@ -576,7 +576,7 @@ guile_corba_sys_register_interface (ORBit_IInterface *iinterface) stub_class = scm_apply (_scm_make_class, scm_cons2 (stub_parent_classes, SCM_EOL, - SCM_LIST4 (k_name, stub_class_name, + scm_list_4 (k_name, stub_class_name, k_metaclass, stub_meta_class)), SCM_EOL); @@ -587,7 +587,7 @@ guile_corba_sys_register_interface (ORBit_IInterface *iinterface) poa_class = scm_apply (_scm_make_class, scm_cons2 (poa_parent_classes, SCM_EOL, - SCM_LIST4 (k_name, poa_class_name, + scm_list_4 (k_name, poa_class_name, k_metaclass, poa_meta_class)), SCM_EOL); @@ -623,7 +623,7 @@ guile_corba_sys_register_interface (ORBit_IInterface *iinterface) method_proc = scm_call_3 (make_method, method_gsubr, scm_symbol_to_string (method_name), imethod_smob); - specializers = SCM_LIST1 (stub_class); + specializers = scm_list_1 (stub_class); num_args = imethod->arguments._length; if (num_args) --num_args; @@ -633,14 +633,14 @@ guile_corba_sys_register_interface (ORBit_IInterface *iinterface) SCM class; class = scm_c_corba_typecode_to_class (arg->tc); - specializers = scm_append_x (SCM_LIST2 (specializers, SCM_LIST1 (class))); + specializers = scm_append_x (scm_list_2 (specializers, scm_list_1 (class))); } - method = scm_make (SCM_LIST3 (scm_class_generic, + method = scm_make (scm_list_3 (scm_class_generic, k_name, method_name)); scm_call_2 (add_method, method, - scm_make (SCM_LIST5 (scm_class_method, + scm_make (scm_list_5 (scm_class_method, k_procedure, method_proc, k_specializers, specializers))); scm_define (method_name, method); diff --git a/gnome/corba/guile-gnome-corba-types.c b/gnome/corba/guile-gnome-corba-types.c index dce2c77..55aa439 100644 --- a/gnome/corba/guile-gnome-corba-types.c +++ b/gnome/corba/guile-gnome-corba-types.c @@ -57,14 +57,14 @@ print_corba_struct (SCM corba_struct, SCM port) CORBA_TypeCode tc; gchar *message; - printer = SCM_PACK (SCM_STRUCT_DATA (corba_struct) [scm_vtable_index_printer]); + printer = SCM_PACK (SCM_STRUCT_DATA (corba_struct) [scm_vtable_index_instance_printer]); if (SCM_NIMP (printer) && scm_procedure_p (printer)) return scm_call_2 (printer, corba_struct, port); tc = SCM_CORBA_STRUCT_TYPECODE (corba_struct); message = g_strdup_printf ("", corba_struct, tc->repo_id); - retval = scm_simple_format (port, scm_makfrom0str (message), SCM_EOL); + retval = scm_simple_format (port, scm_from_locale_string (message), SCM_EOL); g_free (message); return retval; @@ -77,14 +77,14 @@ print_corba_sequence (SCM corba_sequence, SCM port) CORBA_TypeCode tc; gchar *message; - printer = SCM_PACK (SCM_STRUCT_DATA (corba_sequence) [scm_vtable_index_printer]); + printer = SCM_PACK (SCM_STRUCT_DATA (corba_sequence) [scm_vtable_index_instance_printer]); if (SCM_NIMP (printer) && scm_procedure_p (printer)) return scm_call_2 (printer, corba_sequence, port); tc = SCM_CORBA_SEQUENCE_TYPECODE (corba_sequence); message = g_strdup_printf ("", corba_sequence, tc->subtypes [0]->repo_id); - retval = scm_simple_format (port, scm_makfrom0str (message), SCM_EOL); + retval = scm_simple_format (port, scm_from_locale_string (message), SCM_EOL); g_free (message); return retval; @@ -105,8 +105,8 @@ SCM_DEFINE (scm_corba_struct_fields, "corba-struct-fields", 1, 0, 0, fields = SCM_EOL; for (i = 0; i < tc->sub_parts; i++) { - SCM sym = scm_mem2symbol (tc->subnames [i], strlen (tc->subnames [i])); - fields = scm_append_x (SCM_LIST2 (fields, SCM_LIST1 (sym))); + SCM sym = scm_from_locale_symboln (tc->subnames [i], strlen (tc->subnames [i])); + fields = scm_append_x (scm_list_2 (fields, scm_list_1 (sym))); } return fields; @@ -489,7 +489,7 @@ case CORBA_tk_ ## k: \ } case CORBA_tk_string: - retval = scm_mem2string (* (CORBA_char **) any->_value, + retval = scm_from_locale_stringn (* (CORBA_char **) any->_value, strlen (* (CORBA_char **) any->_value)); break; @@ -666,7 +666,7 @@ guile_corba_typecode_print (SCM typecode_smob, SCM port, scm_print_state *pstate CORBA_TypeCode tc = (CORBA_TypeCode) SCM_SMOB_DATA (typecode_smob); scm_puts ("#repo_id), port); + scm_display (scm_from_locale_string (tc->repo_id), port); scm_puts (">", port); /* non-zero means success */ @@ -709,7 +709,7 @@ scm_c_make_corba_object (SCM class, CORBA_Object corba_objref) ORBit_RootObject_duplicate (corba_objref); SCM_NEWSMOB (smob, scm_tc16_corba_object, corba_objref); - object = scm_make (SCM_LIST1 (class)); + object = scm_make (scm_list_1 (class)); scm_slot_set_x (object, scm_sym_corba_objref, smob); return object; @@ -814,19 +814,19 @@ scm_init_gnome_corba_types (void) gsubr = scm_c_make_gsubr ("%print-corba-struct", 2, 0, 0, print_corba_struct); scm_corba_struct_vtable = scm_permanent_object - (scm_make_vtable_vtable (scm_makfrom0str ("srprprprpopopW"), scm_from_int (0), SCM_LIST1 (gsubr))); + (scm_make_vtable_vtable (scm_from_locale_string ("srprprprpopopW"), scm_from_int (0), scm_list_1 (gsubr))); SCM_SET_CORBA_STRUCT_TYPECODE (scm_corba_struct_vtable, TC_CORBA_TypeCode); scm_c_define ("%corba-struct-vtable", scm_corba_struct_vtable); scm_c_define ("%corba-struct-vtable-offset-user", scm_from_int (scm_corba_struct_vtable_offset_user)); - scm_c_define ("%corba-struct-vtable-offset-printer", scm_from_int (scm_vtable_index_printer)); + scm_c_define ("%corba-struct-vtable-offset-printer", scm_from_int (scm_vtable_index_instance_printer)); gsubr = scm_c_make_gsubr ("%print-corba-sequence", 2, 0, 0, print_corba_sequence); scm_corba_sequence_vtable = scm_permanent_object - (scm_make_vtable_vtable (scm_makfrom0str ("srprprprpopW"), scm_from_int (0), SCM_LIST1 (gsubr))); + (scm_make_vtable_vtable (scm_from_locale_string ("srprprprpopW"), scm_from_int (0), scm_list_1 (gsubr))); SCM_SET_CORBA_SEQUENCE_TYPECODE (scm_corba_sequence_vtable, TC_CORBA_TypeCode); scm_c_define ("%corba-sequence-vtable", scm_corba_sequence_vtable); scm_c_define ("%corba-sequence-vtable-offset-user", scm_from_int (scm_corba_sequence_vtable_offset_user)); - scm_c_define ("%corba-sequence-vtable-offset-printer", scm_from_int (scm_vtable_index_printer)); + scm_c_define ("%corba-sequence-vtable-offset-printer", scm_from_int (scm_vtable_index_instance_printer)); scm_c_export ("%corba-struct-vtable", "%corba-struct-vtable-offset-user", diff --git a/gnome/corba/types.scm b/gnome/corba/types.scm index bec438c..b22d641 100644 --- a/gnome/corba/types.scm +++ b/gnome/corba/types.scm @@ -1,6 +1,7 @@ ;; guile-gnome ;; Copyright (C) 2001 Martin Baulig ;; 2003,2004 Andy Wingo +;; 2011 Andreas Rottmann ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -31,7 +32,6 @@ :use-module (oop goops)) (define (gnome-corba-error format-string . args) - (save-stack) (scm-error 'gnome-corba-error #f format-string args '())) (%init-gnome-corba-types) * defs: git 'diff' 'HEAD' diff --git a/gnome/defs/gtk.defs b/gnome/defs/gtk.defs index 8ae6ec4..75f5d2c 100644 --- a/gnome/defs/gtk.defs +++ b/gnome/defs/gtk.defs @@ -16160,7 +16160,7 @@ (return-type "gboolean") (parameters '("const-gchar*" "app_name") - '("gchar**" "app_exec") + '("const-gchar**" "app_exec") '("guint*" "count") '("time_t*" "time_") ) * gconf: git 'diff' 'HEAD' diff --git a/gnome/gw/gconf-support.c b/gnome/gw/gconf-support.c index 698fedc..6fe019a 100644 --- a/gnome/gw/gconf-support.c +++ b/gnome/gw/gconf-support.c @@ -1,5 +1,5 @@ /* guile-gnome - * Copyright (C) 2004 Free Software Foundation, Inc. + * Copyright (C) 2004, 2011 Free Software Foundation, Inc. * * gconf-support.c: Support routines for the gconf wrapper * @@ -26,8 +26,8 @@ #include "guile-gnome-gobject.h" #define GRUNTIME_ERROR(format, func_name, args...) \ - scm_error_scm (scm_str2symbol ("gruntime-error"), scm_makfrom0str (func_name), \ - scm_simple_format (SCM_BOOL_F, scm_makfrom0str (format), \ + scm_error_scm (scm_from_locale_symbol ("gruntime-error"), scm_from_locale_string (func_name), \ + scm_simple_format (SCM_BOOL_F, scm_from_locale_string (format), \ scm_list_n (args, SCM_UNDEFINED)), \ SCM_EOL, SCM_EOL) @@ -57,15 +57,15 @@ SCM scm_c_gconf_value_to_scm (const GConfValue *value) { if (!value) - scm_throw (scm_str2symbol ("value-unset"), SCM_EOL); + scm_throw (scm_from_locale_symbol ("value-unset"), SCM_EOL); switch (value->type) { case GCONF_VALUE_STRING: - return scm_makfrom0str (gconf_value_get_string (value)); + return scm_from_locale_string (gconf_value_get_string (value)); case GCONF_VALUE_INT: - return scm_int2num (gconf_value_get_int (value)); + return scm_from_int (gconf_value_get_int (value)); case GCONF_VALUE_FLOAT: - return scm_float2num (gconf_value_get_float (value)); + return scm_from_double (gconf_value_get_float (value)); case GCONF_VALUE_BOOL: return SCM_BOOL (gconf_value_get_bool (value)); case GCONF_VALUE_SCHEMA: @@ -81,14 +81,14 @@ scm_c_gconf_value_to_scm (const GConfValue *value) for (walk = head; walk; walk = walk->next) { switch (t) { case GCONF_VALUE_STRING: - ret = scm_cons (scm_makfrom0str ((char*)walk->data), ret); + ret = scm_cons (scm_from_locale_string ((char*)walk->data), ret); g_free (walk->data); break; case GCONF_VALUE_INT: - ret = scm_cons (scm_int2num (GPOINTER_TO_INT (walk->data)), ret); + ret = scm_cons (scm_from_int (GPOINTER_TO_INT (walk->data)), ret); break; case GCONF_VALUE_FLOAT: - ret = scm_cons (scm_float2num (*(float*)walk->data), ret); + ret = scm_cons (scm_from_double (*(float*)walk->data), ret); g_free (walk->data); break; case GCONF_VALUE_BOOL: @@ -100,8 +100,8 @@ scm_c_gconf_value_to_scm (const GConfValue *value) ret); break; default: - scm_throw (scm_str2symbol ("unknown-value"), - SCM_LIST1 (scm_from_int (t))); + scm_throw (scm_from_locale_symbol ("unknown-value"), + scm_list_1 (scm_from_int (t))); } } g_slist_free (head); @@ -111,8 +111,8 @@ scm_c_gconf_value_to_scm (const GConfValue *value) return scm_cons (scm_c_gconf_value_to_scm (gconf_value_get_car (value)), scm_c_gconf_value_to_scm (gconf_value_get_cdr (value))); default: - scm_throw (scm_str2symbol ("unknown-value"), - SCM_LIST1 (scm_from_int (value->type))); + scm_throw (scm_from_locale_symbol ("unknown-value"), + scm_list_1 (scm_from_int (value->type))); } return SCM_BOOL_F; /* shouldn't get here */ } @@ -185,15 +185,15 @@ scm_c_scm_to_gconf_value (SCM value) ret = gconf_value_new (GCONF_VALUE_INT); gconf_value_set_int (ret, scm_to_int (value)); } else if (SCM_NFALSEP (scm_exact_p (value))) { - if (SCM_NFALSEP (scm_leq_p (value, scm_uint2num (G_MAXINT)))) { + if (SCM_NFALSEP (scm_leq_p (value, scm_from_uint (G_MAXINT)))) { ret = gconf_value_new (GCONF_VALUE_INT); - gconf_value_set_int (ret, scm_num2int (value, 1, FUNC_NAME)); + gconf_value_set_int (ret, scm_to_int (value)); } else { scm_misc_error (FUNC_NAME, "Invalid value: ~A", scm_list_1 (value)); } } else if (SCM_NFALSEP (scm_inexact_p (value))) { ret = gconf_value_new (GCONF_VALUE_FLOAT); - gconf_value_set_float (ret, scm_num2float (value, 1, FUNC_NAME)); + gconf_value_set_float (ret, scm_to_double (value)); } else if (scm_is_string (value)) { char *chars; ret = gconf_value_new (GCONF_VALUE_STRING); @@ -235,7 +235,7 @@ with_notify_proc (GConfClient *client, guint cnxn_id, GConfEntry *entry, proc = GPOINTER_TO_SCM (user_data); sclient = scm_c_gtype_instance_to_scm ((GTypeInstance*)client); - key = scm_str2symbol (gconf_entry_get_key (entry)); + key = scm_from_locale_symbol (gconf_entry_get_key (entry)); val = scm_c_gconf_value_to_scm (gconf_entry_get_value (entry)); scm_call_4 (proc, sclient, scm_from_uint (cnxn_id), key, val); * glib: git 'diff' 'HEAD' diff --git a/gnome/gobject/gobject.c b/gnome/gobject/gobject.c index 1a8a891..5a6653a 100644 --- a/gnome/gobject/gobject.c +++ b/gnome/gobject/gobject.c @@ -78,7 +78,7 @@ scm_with_c_gobject_get_property (GObject *gobject, guint param_id, scm_c_gvalue_set (dest_gvalue, scm_call_2 (_gobject_get_property, scm_c_gtype_instance_to_scm (gobject), - scm_str2symbol (pspec->name))); + scm_from_locale_symbol (pspec->name))); } static void @@ -94,7 +94,7 @@ scm_with_c_gobject_set_property (GObject *gobject, guint param_id, const GValue { scm_call_3 (_gobject_set_property, scm_c_gtype_instance_to_scm (gobject), - scm_str2symbol (pspec->name), + scm_from_locale_symbol (pspec->name), scm_c_gvalue_to_scm (src_value)); } @@ -188,7 +188,7 @@ scm_c_gobject_construct (SCM instance, SCM initargs) if (!pspec) scm_c_gruntime_error (FUNC_NAME, "No property named ~S in object ~A", - SCM_LIST2 (propname, instance)); + scm_list_2 (propname, instance)); g_value_init (¤t->value, G_PARAM_SPEC_VALUE_TYPE (pspec)); scm_c_gvalue_set (¤t->value, val); @@ -352,17 +352,17 @@ SCM_DEFINE (scm_gtype_register_static, "gtype-register-static", 2, 0, 0, if (gtype) scm_c_gruntime_error (FUNC_NAME, "There is already a type with this name: ~S", - SCM_LIST1 (name)); + scm_list_1 (name)); if (!G_TYPE_IS_DERIVABLE (gtype_parent)) scm_c_gruntime_error (FUNC_NAME, "Cannot derive ~S from non-derivable parent type: ~S", - SCM_LIST2 (name, parent_class)); + scm_list_2 (name, parent_class)); if (!G_TYPE_IS_FUNDAMENTAL (gtype_parent) && !G_TYPE_IS_DEEP_DERIVABLE (gtype_parent)) scm_c_gruntime_error (FUNC_NAME, "Cannot derive ~S from non-fundamental parent type: ~S", - SCM_LIST2 (name, parent_class)); + scm_list_2 (name, parent_class)); g_type_query (gtype_parent, >ype_query); @@ -490,18 +490,18 @@ SCM_DEFINE (scm_gobject_class_install_property, "gobject-class-install-property" if (g_object_class_find_property (gclass, gparam->name)) scm_error (sym_gruntime_error, FUNC_NAME, "There is already a property with this name in class ~S: ~S", - SCM_LIST2 (class, scm_makfrom0str (gparam->name)), SCM_EOL); + scm_list_2 (class, scm_from_locale_string (gparam->name)), SCM_EOL); guile_class = g_type_get_qdata (gtype, quark_guile_gtype_class); if (!guile_class) scm_error (sym_gruntime_error, FUNC_NAME, "Can't add properties to non-derived type: ~S", - SCM_LIST1 (class), SCM_EOL); + scm_list_1 (class), SCM_EOL); if (guile_class->first_instance_created) scm_error (sym_gruntime_error, FUNC_NAME, "Can't add properties after intances have been created: ~S", - SCM_LIST1 (class), SCM_EOL); + scm_list_1 (class), SCM_EOL); id = ++guile_class->last_property_id; g_object_class_install_property (gclass, id, gparam); @@ -536,7 +536,7 @@ SCM_DEFINE (scm_gobject_get_property, "gobject-get-property", 2, 0, 0, if (!pspec) scm_error (sym_gruntime_error, FUNC_NAME, "No such property ~S in class ~S", - SCM_LIST2 (name, scm_class_of (object)), SCM_EOL); + scm_list_2 (name, scm_class_of (object)), SCM_EOL); g_value_init (&value, pspec->value_type); g_object_get_property (gobject, pspec->name, &value); @@ -571,7 +571,7 @@ SCM_DEFINE (scm_gobject_set_property, "gobject-set-property", 3, 0, 0, if (!pspec) scm_error (sym_gruntime_error, FUNC_NAME, "No such property ~S in class ~S", - SCM_LIST2 (name, scm_class_of (object)), SCM_EOL); + scm_list_2 (name, scm_class_of (object)), SCM_EOL); gvalue = scm_c_scm_to_gvalue (pspec->value_type, value); g_object_set_property (gobject, pspec->name, gvalue); diff --git a/gnome/gobject/gparameter.c b/gnome/gobject/gparameter.c index 782ac30..82e5da2 100644 --- a/gnome/gobject/gparameter.c +++ b/gnome/gobject/gparameter.c @@ -33,7 +33,7 @@ #define SCM_ERROR_NOT_YET_IMPLEMENTED(what) \ scm_c_gruntime_error (FUNC_NAME, "Not yet implemented: file ~S line ~S: ~A", \ - SCM_LIST3 (scm_makfrom0str (__FILE__), scm_from_uint (__LINE__), what)) + scm_list_3 (scm_from_locale_string (__FILE__), scm_from_uint (__LINE__), what)) @@ -395,7 +395,7 @@ scm_c_gparam_construct (SCM instance, SCM initargs) else { scm_c_gruntime_error ("%gparam-construct", "Can't create instance of ~A from initargs: ~A", - SCM_LIST2 (scm_class_of (instance), initargs)); + scm_list_2 (scm_class_of (instance), initargs)); } DEBUG_ALLOC ("new guile-owned param spec %p of type %s", diff --git a/gnome/gobject/gsignal.c b/gnome/gobject/gsignal.c index 59bccc4..e9062a2 100644 --- a/gnome/gobject/gsignal.c +++ b/gnome/gobject/gsignal.c @@ -94,7 +94,7 @@ SCM_DEFINE (scm_gsignal_query, "gsignal-query", 2, 0, 0, free (cname); if (!id) scm_c_gruntime_error (FUNC_NAME, "Unknown signal ~A on class ~A", - SCM_LIST2 (name, class)); + scm_list_2 (name, class)); return scm_c_gsignal_query (id); } @@ -206,7 +206,7 @@ SCM_DEFINE (scm_gtype_instance_signal_emit, "gtype-instance-signal-emit", 2, 0, if (!id) scm_c_gruntime_error (FUNC_NAME, "Unknown signal ~A on object ~A", - SCM_LIST2 (name, object)); + scm_list_2 (name, object)); g_signal_query (id, &query); diff --git a/gnome/gobject/gtype.c b/gnome/gobject/gtype.c index 7c5438b..86f7780 100644 --- a/gnome/gobject/gtype.c +++ b/gnome/gobject/gtype.c @@ -189,7 +189,7 @@ SCM_DEFINE (scm_gtype_name_to_class, "gtype-name->class", 1, 0, 0, if (!type) scm_c_gruntime_error (FUNC_NAME, "No GType registered with name ~A", - SCM_LIST1 (name)); + scm_list_1 (name)); scm_dynwind_end (); @@ -208,7 +208,7 @@ gtype_struct_offset (SCM class) scm_c_gruntime_error ("%gtype-class-bind", "`gtype' not allocated a slot in struct!", - SCM_LIST1 (class)); + scm_list_1 (class)); return -1; } @@ -238,13 +238,13 @@ SCM_DEFINE_STATIC (scm_sys_gtype_class_bind, "%gtype-class-bind", 2, 0, 0, if (!gtype) scm_c_gruntime_error (FUNC_NAME, "No GType registered with name ~A", - SCM_LIST1 (type_name)); + scm_list_1 (type_name)); if (SCM_NFALSEP (scm_c_gtype_lookup_class (gtype))) scm_c_gruntime_error (FUNC_NAME, "~A already has a GOOPS class, use gtype-name->class", - SCM_LIST1 (type_name)); + scm_list_1 (type_name)); g_type_set_qdata (gtype, quark_class, scm_permanent_object (class)); slots = SCM_STRUCT_DATA (class); @@ -298,7 +298,7 @@ SCM_DEFINE_STATIC (scm_sys_gtype_class_inherit_magic, "%gtype-class-inherit-magi SCM_STRUCT_DATA (parent)[scm_vtable_index_instance_finalize]; } else { scm_c_gruntime_error (FUNC_NAME, "No free function for SCM class %s!", - SCM_LIST1 (class)); + scm_list_1 (class)); #else } else { SCM parent = scm_cadr (scm_class_precedence_list (class)); @@ -455,7 +455,7 @@ scm_c_gtype_instance_construct (SCM object, SCM initargs) else scm_c_gruntime_error ("%gtype-instance-construct", "Don't know how to construct instances of class ~A", - SCM_LIST1 (scm_c_gtype_to_class (type))); + scm_list_1 (scm_c_gtype_to_class (type))); return NULL; } @@ -613,14 +613,14 @@ scm_c_scm_to_gtype_instance (SCM instance) if (ulong == SCM_UNBOUND) scm_c_gruntime_error ("%scm->gtype-instance", "Object ~A is uninitialized.", - SCM_LIST1 (instance)); + scm_list_1 (instance)); ginstance = (gpointer)scm_to_ulong (ulong); if (!ginstance) scm_c_gruntime_error ("%scm->gtype-instance", "Object ~A has been destroyed.", - SCM_LIST1 (instance)); + scm_list_1 (instance)); return ginstance; } diff --git a/gnome/gobject/gtype.scm b/gnome/gobject/gtype.scm index dcf7baf..5b0ef21 100644 --- a/gnome/gobject/gtype.scm +++ b/gnome/gobject/gtype.scm @@ -57,7 +57,6 @@ (define (gruntime-error format-string . args) "Signal a runtime error. The error will be thrown to the key @code{gruntime-error}." - (save-stack) (scm-error 'gruntime-error #f format-string args '())) diff --git a/gnome/gobject/guile-support.c b/gnome/gobject/guile-support.c index 7461ab9..3c7d02d 100644 --- a/gnome/gobject/guile-support.c +++ b/gnome/gobject/guile-support.c @@ -25,22 +25,6 @@ #include -#ifndef SCM_VERSION_17X - -SCM -scm_str2string (const char *src) -{ - return scm_mem2string (src, strlen (src)); -} - -void * -scm_with_guile (void*(*func)(void*), void *data) -{ - return func(data); -} - -#endif - char* scm_to_locale_string_dynwind (SCM s) { diff --git a/gnome/gobject/guile-support.h b/gnome/gobject/guile-support.h index a77599d..d30ec89 100644 --- a/gnome/gobject/guile-support.h +++ b/gnome/gobject/guile-support.h @@ -30,29 +30,8 @@ G_BEGIN_DECLS -/* Define this macro if Guile 1.7.x or better is in use. */ -#if defined (SCM_MINOR_VERSION) && (SCM_MINOR_VERSION >= 7) && \ - defined (SCM_MAJOR_VERSION) && (SCM_MAJOR_VERSION >= 1) -#define SCM_VERSION_17X 1 -#endif - -/* Support for coding against Guile 1.7 */ -#ifndef SCM_VERSION_17X - -#define scm_gc_malloc(size, what) scm_must_malloc((size), (what)) -#define scm_gc_free(mem, size, what) \ - do{ scm_must_free (mem); scm_done_free (size); } while (0) - -#define SCM_VECTOR_SET(x, idx, val) (SCM_VELTS(x)[(idx)] = (val)) -#define SCM_VECTOR_REF(x, idx) (SCM_VELTS(x)[(idx)]) - -#define scm_gc_register_collectable_memory(mem, size, what) -#define scm_gc_unregister_collectable_memory(mem, size, what) - -void *scm_with_guile (void*(*func)(void*), void *data); - -SCM scm_str2string (const char *src); - +#if SCM_MAJOR_VERSION < 2 +#define scm_vtable_index_instance_printer scm_vtable_index_printer #endif char* scm_to_locale_string_dynwind (SCM s); diff --git a/gnome/gobject/gutil.c b/gnome/gobject/gutil.c index 8906eb4..e775551 100644 --- a/gnome/gobject/gutil.c +++ b/gnome/gobject/gutil.c @@ -1,5 +1,5 @@ /* guile-gnome - * Copyright (C) 2005 Andreas Rottmann + * Copyright (C) 2005, 2011 Andreas Rottmann * * gutil.c: Some GLib-related utilties * @@ -26,9 +26,9 @@ SCM scm_c_gerror_to_scm (GError *error) { - return scm_list_3 (scm_ulong2num(error->domain), - scm_ulong2num(error->code), - scm_makfrom0str(error->message)); + return scm_list_3 (scm_from_ulong(error->domain), + scm_from_ulong(error->code), + scm_from_locale_string(error->message)); } void @@ -36,5 +36,5 @@ scm_c_raise_gerror (GError *error) { SCM scm_gerror = scm_c_gerror_to_scm (error); g_error_free (error); - scm_throw (scm_str2symbol("g-error"), scm_gerror); + scm_throw (scm_from_locale_symbol("g-error"), scm_gerror); } diff --git a/gnome/gobject/gvalue.c b/gnome/gobject/gvalue.c index fbdd23a..4b00e95 100644 --- a/gnome/gobject/gvalue.c +++ b/gnome/gobject/gvalue.c @@ -237,10 +237,10 @@ scm_c_gvalue_ref (const GValue *gvalue) return scm_from_ulong_long (g_value_get_uint64 (gvalue)); case G_TYPE_FLOAT: - return scm_make_real ((double) g_value_get_float (gvalue)); + return scm_from_double ((double) g_value_get_float (gvalue)); case G_TYPE_DOUBLE: - return scm_make_real (g_value_get_double (gvalue)); + return scm_from_double (g_value_get_double (gvalue)); case G_TYPE_STRING: { @@ -289,7 +289,7 @@ scm_c_gvalue_set (GValue *gvalue, SCM value) return; } else { scm_c_gruntime_error (FUNC_NAME, "Can't make ~a into ~a", - SCM_LIST2 (value, scm_c_gtype_to_class (gtype))); + scm_list_2 (value, scm_c_gtype_to_class (gtype))); return; } } @@ -339,14 +339,14 @@ scm_c_gvalue_set (GValue *gvalue, SCM value) break; case G_TYPE_FLOAT: { - double x = scm_num2dbl (value, FUNC_NAME); + double x = scm_to_double (value); SCM_ASSERT_RANGE (2, value, (- G_MAXFLOAT < x) && (x < G_MAXFLOAT)); g_value_set_float (gvalue, (float) x); break; } case G_TYPE_DOUBLE: - g_value_set_double (gvalue, scm_num2dbl (value, FUNC_NAME)); + g_value_set_double (gvalue, scm_to_double (value)); break; case G_TYPE_STRING: @@ -405,7 +405,7 @@ scm_c_gvalue_set (GValue *gvalue, SCM value) scm_c_gruntime_error (FUNC_NAME, "Don't know how to make values of type ~A", - SCM_LIST1 (scm_c_gtype_to_class (gtype))); + scm_list_1 (scm_c_gtype_to_class (gtype))); } } #undef FUNC_NAME @@ -419,7 +419,7 @@ scm_c_scm_to_enum_value (GEnumClass *enum_class, SCM value) #define ERROR(x) \ scm_c_gruntime_error \ (FUNC_NAME, "Bad enum value for enumerated type `~a': ~a", \ - SCM_LIST2 (scm_from_locale_string \ + scm_list_2 (scm_from_locale_string \ (g_type_name (G_TYPE_FROM_CLASS (enum_class))), x)) if (scm_is_signed_integer (value, SCM_T_INT32_MIN, SCM_T_INT32_MAX)) { @@ -473,7 +473,7 @@ scm_c_scm_to_flags_value (GFlagsClass *flags_class, SCM value) #define ERROR(x) \ scm_c_gruntime_error \ (FUNC_NAME, "Bad value for flags type `~a': ~a", \ - SCM_LIST2 (scm_from_locale_string \ + scm_list_2 (scm_from_locale_string \ (g_type_name (G_TYPE_FROM_CLASS (flags_class))), x)) if (scm_is_unsigned_integer (value, 0, SCM_T_UINT32_MAX)) { @@ -753,7 +753,7 @@ SCM_DEFINE (scm_genum_register_static, "genum-register-static", 2, 0, 0, if (type) scm_c_gruntime_error (FUNC_NAME, "There is already a type with this name: ~S", - SCM_LIST1 (name)); + scm_list_1 (name)); length = scm_c_vector_length (vtable); @@ -807,7 +807,7 @@ SCM_DEFINE (scm_gflags_register_static, "gflags-register-static", 2, 0, 0, if (type) scm_c_gruntime_error (FUNC_NAME, "There is already a type with this name: ~S", - SCM_LIST1 (name)); + scm_list_1 (name)); length = scm_c_vector_length (vtable); diff --git a/gnome/gw/glib-support.c b/gnome/gw/glib-support.c index 1cf1e3c..53bc2d9 100644 --- a/gnome/gw/glib-support.c +++ b/gnome/gw/glib-support.c @@ -29,7 +29,7 @@ #include #define GRUNTIME_ERROR(format, func_name, args...) \ - scm_error (scm_str2symbol ("gruntime-error"), func_name, format, \ + scm_error (scm_from_locale_symbol ("gruntime-error"), func_name, format, \ ##args, SCM_EOL) size_t @@ -260,7 +260,7 @@ _wrap_g_main_loop_run (GMainLoop *loop) SCM _wrap_g_string_get_str (GString *str) { - return scm_mem2string (str->str, str->len); + return scm_from_locale_stringn (str->str, str->len); } struct io_args { @@ -277,7 +277,7 @@ _with_io_func (gpointer data) result = scm_call_2 (args->proc, gw_wcp_assimilate_ptr (args->source, iochannel_type), - scm_long2num (args->condition)); + scm_from_long (args->condition)); return result != SCM_BOOL_F ? (void*)1 : (void*)0; } diff --git a/gnome/gw/support/gobject.scm b/gnome/gw/support/gobject.scm index 699bf05..712a0a8 100644 --- a/gnome/gw/support/gobject.scm +++ b/gnome/gw/support/gobject.scm @@ -1054,6 +1054,7 @@ example: ;;; We override the generation of the scheme wrapper, because we want to ;;; avoid listing all exports of the module. See the lengthy comment in ;;; guile/g-wrap/guile-runtime.c in g-wrap for a rationale. +#; (define-method (generate-wrapset (lang ) (wrapset ) (basename )) diff --git a/shlib-dirs.ac b/shlib-dirs.ac index 299461e..a529aed 100644 --- a/shlib-dirs.ac +++ b/shlib-dirs.ac @@ -1,2 +1,3 @@ gnome/gw gnome/gobject +test-suite diff --git a/test-suite/guile-gobject-test b/test-suite/guile-gobject-test index c0c2a9e..f7aa523 100755 --- a/test-suite/guile-gobject-test +++ b/test-suite/guile-gobject-test @@ -7,7 +7,7 @@ exec ${srcdir:-.}/guile-test-env guile --debug -e main -s "$0" "$@" ;;;; Stolen for guile-gobject by Andreas Rottmann ;;;; --- Oct 2003 ;;;; -;;;; Copyright (C) 1999 - 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 1999 - 2003, 2011 Free Software Foundation, Inc. ;;;; ;;;; 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 @@ -93,6 +93,7 @@ exec ${srcdir:-.}/guile-test-env guile --debug -e main -s "$0" "$@" #:use-module (ice-9 getopt-long) #:use-module (ice-9 and-let-star) #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-13) #:export (main data-file-name test-file-name)) @@ -165,7 +166,7 @@ exec ${srcdir:-.}/guile-test-env guile --debug -e main -s "$0" "$@" (let ((root-len (+ 1 (string-length test-dir))) (tests '())) (for-each-file (lambda (file) - (if (has-suffix? file ".test") + (if (string-suffix? ".test" file) (let ((short-name (substring file root-len))) (set! tests (cons short-name tests)))) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 46da7e1..b63c595 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,31 +1,45 @@ ;;;; test-suite/lib.scm --- generic support for testing -;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010, +;;;; 2011 Free Software Foundation, Inc. ;;;; -;;;; 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 free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, 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. +;;;; GNU Lesser 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, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite lib) - :use-module (ice-9 stack-catch) - :use-module (ice-9 regex) - :export ( + #:use-module (ice-9 stack-catch) + #:use-module (ice-9 regex) + #:autoload (srfi srfi-1) (append-map) + #:autoload (system base compile) (compile) + #:export ( ;; Exceptions which are commonly being tested for. + exception:syntax-pattern-unmatched exception:bad-variable exception:missing-expression exception:out-of-range exception:unbound-var + exception:used-before-defined exception:wrong-num-args exception:wrong-type-arg + exception:numerical-overflow + exception:struct-set!-denied + exception:system-error + exception:encoding-error + exception:miscellaneous-error + exception:string-contains-nul + exception:read-error + exception:null-pointer-error + exception:vm-error ;; Reporting passes and failures. run-test @@ -33,9 +47,18 @@ pass-if-exception expect-fail-exception ;; Naming groups of tests in a regular fashion. - with-test-prefix with-test-prefix* current-test-prefix + with-test-prefix + with-test-prefix* + with-test-prefix/c&e + current-test-prefix format-test-name + ;; Using the debugging evaluator. + with-debugging-evaluator with-debugging-evaluator* + + ;; Using a given locale + with-locale with-locale* with-latin1-locale with-latin1-locale* + ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts @@ -155,7 +178,7 @@ ;;;; ("basic arithmetic" "subtraction"), and ;;;; ("multiplication"). ;;;; -;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends +;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX appends ;;;; a new element to the current prefix: ;;;; ;;;; (with-test-prefix "arithmetic" @@ -234,18 +257,43 @@ ;;;; ;;; Define some exceptions which are commonly being tested for. +(define exception:syntax-pattern-unmatched + (cons 'syntax-error "source expression failed to match any pattern")) (define exception:bad-variable (cons 'syntax-error "Bad variable")) (define exception:missing-expression (cons 'misc-error "^missing or extra expression")) (define exception:out-of-range - (cons 'out-of-range "^Argument .*out of range")) + (cons 'out-of-range "^.*out of range")) (define exception:unbound-var (cons 'unbound-variable "^Unbound variable")) +(define exception:used-before-defined + (cons 'unbound-variable "^Variable used before given a value")) (define exception:wrong-num-args (cons 'wrong-number-of-args "^Wrong number of arguments")) (define exception:wrong-type-arg - (cons 'wrong-type-arg "^Wrong type argument")) + (cons 'wrong-type-arg "^Wrong type")) +(define exception:numerical-overflow + (cons 'numerical-overflow "^Numerical overflow")) +(define exception:struct-set!-denied + (cons 'misc-error "^set! denied for field")) +(define exception:system-error + (cons 'system-error ".*")) +(define exception:encoding-error + (cons 'encoding-error "(cannot convert to output locale|input (locale conversion|decoding) error)")) +(define exception:miscellaneous-error + (cons 'misc-error "^.*")) +(define exception:read-error + (cons 'read-error "^.*$")) +(define exception:null-pointer-error + (cons 'null-pointer-error "^.*$")) +(define exception:vm-error + (cons 'vm-error "^.*$")) + +;; as per throw in scm_to_locale_stringn() +(define exception:string-contains-nul + (cons 'misc-error "^string contains #\\\\nul character")) + ;;; Display all parameters to the default output port, followed by a newline. (define (display-line . objs) @@ -293,20 +341,24 @@ (set! run-test local-run-test)) ;;; A short form for tests that are expected to pass, taken from Greg. -(defmacro pass-if (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (pass-if (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #t (lambda () ,name)) - `(run-test ,name #t (lambda () ,@rest)))) +(define-syntax pass-if + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (pass-if (even? 2)) + ;; where the body should also be the name. + (run-test 'name #t (lambda () name))) + ((_ name rest ...) + (run-test name #t (lambda () rest ...))))) ;;; A short form for tests that are expected to fail, taken from Greg. -(defmacro expect-fail (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (expect-fail (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #f (lambda () ,name)) - `(run-test ,name #f (lambda () ,@rest)))) +(define-syntax expect-fail + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (expect-fail (even? 2)) + ;; where the body should also be the name. + (run-test 'name #f (lambda () name))) + ((_ name rest ...) + (run-test name #f (lambda () rest ...))))) ;;; A helper function to implement the macros that test for exceptions. (define (run-test-exception name exception expect-pass thunk) @@ -338,12 +390,16 @@ (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. -(defmacro pass-if-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) +(define-syntax pass-if-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #t (lambda () body rest ...))))) ;;; A short form for tests expected to fail to throw a certain exception. -(defmacro expect-fail-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) +(define-syntax expect-fail-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #f (lambda () body rest ...))))) ;;;; TEST NAMES @@ -351,15 +407,18 @@ ;;;; Turn a test name into a nice human-readable string. (define (format-test-name name) - (call-with-output-string - (lambda (port) - (let loop ((name name) - (separator "")) - (if (pair? name) - (begin - (display separator port) - (display (car name) port) - (loop (cdr name) ": "))))))) + ;; Choose a Unicode-capable encoding so that the string port can contain any + ;; valid Unicode character. + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-output-string + (lambda (port) + (let loop ((name name) + (separator "")) + (if (pair? name) + (begin + (display separator port) + (display (car name) port) + (loop (cdr name) ": ")))))))) ;;;; For a given test-name, deliver the full name including all prefixes. (define (full-name name) @@ -384,8 +443,97 @@ ;;; The name prefix is only changed within the dynamic scope of the ;;; with-test-prefix expression. Return the value returned by the last ;;; BODY expression. -(defmacro with-test-prefix (prefix . body) - `(with-test-prefix* ,prefix (lambda () ,@body))) +(define-syntax with-test-prefix + (syntax-rules () + ((_ prefix body ...) + (with-test-prefix* prefix (lambda () body ...))))) + +(define-syntax c&e + (syntax-rules (pass-if pass-if-exception) + "Run the given tests both with the evaluator and the compiler/VM." + ((_ (pass-if test-name exp)) + (begin (pass-if (string-append test-name " (eval)") + (primitive-eval 'exp)) + (pass-if (string-append test-name " (compile)") + (compile 'exp #:to 'value #:env (current-module))))) + ((_ (pass-if-exception test-name exc exp)) + (begin (pass-if-exception (string-append test-name " (eval)") + exc (primitive-eval 'exp)) + (pass-if-exception (string-append test-name " (compile)") + exc (compile 'exp #:to 'value + #:env (current-module))))))) + +;;; (with-test-prefix/c&e PREFIX BODY ...) +;;; Same as `with-test-prefix', but the enclosed tests are run both with +;;; the compiler/VM and the evaluator. +(define-syntax with-test-prefix/c&e + (syntax-rules () + ((_ section-name exp ...) + (with-test-prefix section-name (c&e exp) ...)))) + +;;; Call THUNK using the debugging evaluator. +(define (with-debugging-evaluator* thunk) + (let ((dopts #f)) + (dynamic-wind + (lambda () + (set! dopts (debug-options))) + thunk + (lambda () + (debug-options dopts))))) + +;;; Evaluate BODY... using the debugging evaluator. +(define-macro (with-debugging-evaluator . body) + `(with-debugging-evaluator* (lambda () ,@body))) + +;;; Call THUNK with a given locale +(define (with-locale* nloc thunk) + (let ((loc #f)) + (dynamic-wind + (lambda () + (if (defined? 'setlocale) + (begin + (set! loc (false-if-exception (setlocale LC_ALL))) + (if (or (not loc) + (not (false-if-exception (setlocale LC_ALL nloc)))) + (throw 'unresolved))) + (throw 'unresolved))) + thunk + (lambda () + (if (and (defined? 'setlocale) loc) + (setlocale LC_ALL loc)))))) + +;;; Evaluate BODY... using the given locale. +(define-syntax with-locale + (syntax-rules () + ((_ loc body ...) + (with-locale* loc (lambda () body ...))))) + +;;; Try out several ISO-8859-1 locales and run THUNK under the one that works +;;; (if any). +(define (with-latin1-locale* thunk) + (define %locales + (append-map (lambda (name) + (list (string-append name ".ISO-8859-1") + (string-append name ".iso88591") + (string-append name ".ISO8859-1"))) + '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US" + "fr_FR" "pt_PT" "nl_NL" "sv_SE"))) + + (let loop ((locales %locales)) + (if (null? locales) + (throw 'unresolved) + (catch 'unresolved + (lambda () + (with-locale* (car locales) thunk)) + (lambda (key . args) + (loop (cdr locales))))))) + +;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none +;;; was found. +(define-syntax with-latin1-locale + (syntax-rules () + ((_ body ...) + (with-latin1-locale* (lambda () body ...))))) ;;;; REPORTERS * gnome-vfs: git 'diff' 'HEAD' diff --git a/gnome/gw/gnome-vfs-port.c b/gnome/gw/gnome-vfs-port.c index 1075317..d4249fe 100644 --- a/gnome/gw/gnome-vfs-port.c +++ b/gnome/gw/gnome-vfs-port.c @@ -1,5 +1,5 @@ /* guile-gnome - * Copyright (C) 2004, 2009 Free Software Foundation, Inc. + * Copyright (C) 2004, 2009, 2011 Free Software Foundation, Inc. * * gnome-vfs-support.c: Support routines for the gnome-vfs wrapper * @@ -28,48 +28,13 @@ #include -/* Define this macro if Guile 1.7.x or better is in use. */ -#if defined (SCM_MINOR_VERSION) && (SCM_MINOR_VERSION >= 7) && \ - defined (SCM_MAJOR_VERSION) && (SCM_MAJOR_VERSION >= 1) -#define SCM_VERSION_17X 1 -#endif - #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION < 9 typedef off_t scm_t_off; #endif -/* Support for coding against Guile 1.7 */ -#ifndef SCM_VERSION_17X - -#define scm_gc_malloc(size, what) scm_must_malloc((size), (what)) -#define scm_gc_free(mem, size, what) \ - do{ scm_must_free (mem); scm_done_free (size); } while (0) - -#define LOCK SCM_DEFER_INTS -#define UNLOCK SCM_ALLOW_INTS - -static SCM -scm_new_port_table_entry (scm_t_bits tag) -#define FUNC_NAME "scm_new_port_table_entry" -{ - SCM port; - scm_t_port *pt; - - SCM_NEWCELL (port); - pt = scm_add_to_port_table (port); - SCM_SET_CELL_TYPE(port, tag); - SCM_SETPTAB_ENTRY (port, pt); - return port; -} -#undef FUNC_NAME - -#else /* SCM_VERSION_17X */ - #define LOCK scm_i_pthread_mutex_lock (&scm_i_port_table_mutex) #define UNLOCK scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex) -#endif /* SCM_VERSION_17X */ - static scm_t_bits scm_tc16_vport = 0; #define CHECK_RESULT(res) \ @@ -150,7 +115,7 @@ scm_gnome_vfs_handle_to_port (GnomeVFSHandle *handle, GnomeVFSOpenMode mode, scm_vport_buffer_add (port, 0, 0); else scm_vport_buffer_add (port, -1, -1); - SCM_SET_FILENAME (port, scm_makfrom0str (uri)); + SCM_SET_FILENAME (port, scm_from_locale_string (uri)); UNLOCK; diff --git a/gnome/gw/gnome-vfs-support.h b/gnome/gw/gnome-vfs-support.h index 5469803..d0c7198 100644 --- a/gnome/gw/gnome-vfs-support.h +++ b/gnome/gw/gnome-vfs-support.h @@ -26,12 +26,12 @@ #include "guile-gnome-gobject.h" #define RESULT_ERROR(result) \ - scm_throw (scm_str2symbol ("gnome-vfs-error"), \ + scm_throw (scm_from_locale_symbol ("gnome-vfs-error"), \ scm_list_1 \ - (scm_str2symbol (g_enum_get_value \ - ((GEnumClass*)g_type_class_peek \ - (GNOME_VFS_TYPE_VFS_RESULT), \ - result)->value_nick))) + (scm_from_locale_symbol (g_enum_get_value \ + ((GEnumClass*)g_type_class_peek \ + (GNOME_VFS_TYPE_VFS_RESULT), \ + result)->value_nick))) GnomeVFSDirectoryHandle *_wrap_gnome_vfs_directory_open (const gchar *text_uri, GnomeVFSFileInfoOptions options); GnomeVFSDirectoryHandle *_wrap_gnome_vfs_directory_open_from_uri (GnomeVFSURI *uri, GnomeVFSFileInfoOptions options); * gtk: git 'diff' 'HEAD' diff --git a/gnome/gw/gdk-support.c b/gnome/gw/gdk-support.c index f0ed87f..716f6ed 100644 --- a/gnome/gw/gdk-support.c +++ b/gnome/gw/gdk-support.c @@ -43,7 +43,7 @@ gdk_event_to_vector (GdkEvent *event) VSET (ret, 0, scm_from_int (event->type)); VSET (ret, 1, scm_c_gtype_instance_to_scm (ekey.window)); VSET (ret, 2, ekey.send_event ? SCM_BOOL_T : SCM_BOOL_F); - VSET (ret, 3, scm_ulong2num (ekey.time)); + VSET (ret, 3, scm_from_ulong (ekey.time)); VSET (ret, 4, scm_from_int (ekey.state)); VSET (ret, 5, scm_from_int (ekey.keyval)); VSET (ret, 6, scm_from_int (ekey.hardware_keycode)); @@ -64,14 +64,14 @@ gdk_event_to_vector (GdkEvent *event) VSET (ret, 0, scm_from_int (event->type)); VSET (ret, 1, scm_c_gtype_instance_to_scm (ebutton.window)); VSET (ret, 2, ebutton.send_event ? SCM_BOOL_T : SCM_BOOL_F); - VSET (ret, 3, scm_ulong2num (ebutton.time)); - VSET (ret, 4, scm_double2num (ebutton.x)); - VSET (ret, 5, scm_double2num (ebutton.y)); + VSET (ret, 3, scm_from_ulong (ebutton.time)); + VSET (ret, 4, scm_from_double (ebutton.x)); + VSET (ret, 5, scm_from_double (ebutton.y)); VSET (ret, 6, scm_from_int (ebutton.state)); VSET (ret, 7, scm_from_int (ebutton.button)); VSET (ret, 8, scm_c_gtype_instance_to_scm (ebutton.device)); - VSET (ret, 9, scm_double2num (ebutton.x_root)); - VSET (ret, 10, scm_double2num (ebutton.y_root)); + VSET (ret, 9, scm_from_double (ebutton.x_root)); + VSET (ret, 10, scm_from_double (ebutton.y_root)); return ret; } case GDK_ENTER_NOTIFY: @@ -92,11 +92,11 @@ gdk_event_to_vector (GdkEvent *event) else VSET (ret, 3, SCM_BOOL_F); - VSET (ret, 4, scm_ulong2num (ecrossing.time)); - VSET (ret, 5, scm_double2num (ecrossing.x)); - VSET (ret, 6, scm_double2num (ecrossing.y)); - VSET (ret, 7, scm_double2num (ecrossing.x_root)); - VSET (ret, 8, scm_double2num (ecrossing.y_root)); + VSET (ret, 4, scm_from_ulong (ecrossing.time)); + VSET (ret, 5, scm_from_double (ecrossing.x)); + VSET (ret, 6, scm_from_double (ecrossing.y)); + VSET (ret, 7, scm_from_double (ecrossing.x_root)); + VSET (ret, 8, scm_from_double (ecrossing.y_root)); VSET (ret, 9, scm_from_int (ecrossing.mode)); VSET (ret, 10, scm_from_int (ecrossing.detail)); VSET (ret, 11, SCM_BOOL (ecrossing.focus)); @@ -116,10 +116,10 @@ gdk_event_to_vector (GdkEvent *event) VSET (ret, 0, scm_from_int (event->type)); VSET (ret, 1, scm_c_gtype_instance_to_scm (eselection.window)); VSET (ret, 2, eselection.send_event ? SCM_BOOL_T : SCM_BOOL_F); - VSET (ret, 3, scm_take0str (gdk_atom_name (eselection.selection))); - VSET (ret, 4, scm_take0str (gdk_atom_name (eselection.target))); - VSET (ret, 5, scm_take0str (gdk_atom_name (eselection.property))); - VSET (ret, 6, scm_ulong2num (eselection.time)); + VSET (ret, 3, scm_take_locale_string (gdk_atom_name (eselection.selection))); + VSET (ret, 4, scm_take_locale_string (gdk_atom_name (eselection.target))); + VSET (ret, 5, scm_take_locale_string (gdk_atom_name (eselection.property))); + VSET (ret, 6, scm_from_ulong (eselection.time)); VSET (ret, 7, scm_from_int (eselection.requestor)); return ret; @@ -135,15 +135,15 @@ gdk_event_to_vector (GdkEvent *event) VSET (ret, 0, scm_from_int (event->type)); VSET (ret, 1, scm_c_gtype_instance_to_scm (emotion.window)); VSET (ret, 2, emotion.send_event ? SCM_BOOL_T : SCM_BOOL_F); - VSET (ret, 3, scm_ulong2num (emotion.time)); - VSET (ret, 4, scm_double2num (emotion.x)); - VSET (ret, 5, scm_double2num (emotion.y)); + VSET (ret, 3, scm_from_ulong (emotion.time)); + VSET (ret, 4, scm_from_double (emotion.x)); + VSET (ret, 5, scm_from_double (emotion.y)); VSET (ret, 6, scm_from_int (emotion.state)); VSET (ret, 7, emotion.is_hint ? SCM_BOOL_T : SCM_BOOL_F); VSET (ret, 8, scm_c_gtype_instance_to_scm (emotion.device)); - VSET (ret, 9, scm_double2num (emotion.x_root)); - VSET (ret, 10, scm_double2num (emotion.y_root)); + VSET (ret, 9, scm_from_double (emotion.x_root)); + VSET (ret, 10, scm_from_double (emotion.y_root)); return ret; } case GDK_WINDOW_STATE: @@ -212,7 +212,7 @@ scm_scm_to_gdk_rectangle (SCM scm) GdkRectangle *ret = gdk_rectangle_new (); #define GET_VINT(v,i) \ - scm_num2int (scm_vector_ref (v, scm_from_int(i)), 0, FUNC_NAME) + scm_to_int (scm_vector_ref (v, scm_from_int(i))) ret->x = GET_VINT (scm, 0); ret->y = GET_VINT (scm, 1); @@ -228,9 +228,9 @@ scm_gdk_color_to_scm (GdkColor *c) { SCM ret = scm_c_make_vector (3, SCM_BOOL_F); - VSET (ret, 0, scm_ushort2num (c->red)); - VSET (ret, 1, scm_ushort2num (c->green)); - VSET (ret, 2, scm_ushort2num (c->blue)); + VSET (ret, 0, scm_from_ushort (c->red)); + VSET (ret, 1, scm_from_ushort (c->green)); + VSET (ret, 2, scm_from_ushort (c->blue)); return ret; } @@ -265,7 +265,7 @@ scm_scm_to_gdk_color (SCM scm) } #define GET_VUSHORT(v,i) \ - scm_num2ushort (scm_vector_ref (v, scm_from_int (i)), 0, FUNC_NAME) + scm_to_ushort (scm_vector_ref (v, scm_from_int (i))) ret->red = GET_VUSHORT (scm, 0); ret->green = GET_VUSHORT (scm, 1); diff --git a/gnome/gw/gtk-support.c b/gnome/gw/gtk-support.c index e6bc9c6..3336ad8 100644 --- a/gnome/gw/gtk-support.c +++ b/gnome/gw/gtk-support.c @@ -508,7 +508,7 @@ _wrap_gtk_stock_lookup (const gchar *stock_id) GtkStockItem item; if (gtk_stock_lookup (stock_id, &item)) { - return SCM_LIST5 (scm_from_locale_string (item.stock_id), + return scm_list_5 (scm_from_locale_string (item.stock_id), scm_from_locale_string (item.label), scm_from_uint (item.modifier), scm_from_uint (item.keyval), @@ -1012,7 +1012,7 @@ gtk_widget_get_window (GtkWidget *widget) } GdkRectangle* -gtk_widget_get_allocation (GtkWidget *widget) +_gtk_widget_get_allocation (GtkWidget *widget) { GdkRectangle *ret = g_new (GdkRectangle, 1); *ret = widget->allocation; diff --git a/gnome/gw/gtk-support.h b/gnome/gw/gtk-support.h index 0326cd1..79009c0 100644 --- a/gnome/gw/gtk-support.h +++ b/gnome/gw/gtk-support.h @@ -117,6 +117,6 @@ void _wrap_gtk_tree_view_column_set_cell_data_func (GtkTreeViewColumn *tree_colu guint _wrap_gtk_ui_manager_add_ui_from_string (GtkUIManager *ui, const gchar *string, GError **error); GdkWindow* gtk_widget_get_window (GtkWidget *widget); -GdkRectangle* gtk_widget_get_allocation (GtkWidget *widget); +GdkRectangle* _gtk_widget_get_allocation (GtkWidget *widget); void _wrap_gtk_drag_dest_set (GtkWidget *widget, GtkDestDefaults flags, const GList *types, GdkDragAction actions); GtkStateType gtk_widget_get_state (GtkWidget *widget); diff --git a/gnome/overrides/gtk.defs b/gnome/overrides/gtk.defs index e69a5a2..e914f70 100644 --- a/gnome/overrides/gtk.defs +++ b/gnome/overrides/gtk.defs @@ -848,7 +848,8 @@ (define-method get-allocation (of-object "GtkWidget") - (c-name "gtk_widget_get_allocation") + (c-name "_gtk_widget_get_allocation") + (overrides "gtk_widget_get_allocation") (return-type "GdkRectangle*")) ;; same as GtkAllocation (define-method get_state * libglade: git 'diff' 'HEAD' diff --git a/gnome/gw/glade-support.c b/gnome/gw/glade-support.c index b8f18ea..86d4507 100644 --- a/gnome/gw/glade-support.c +++ b/gnome/gw/glade-support.c @@ -26,8 +26,8 @@ #include "guile-gnome-gobject.h" #define GRUNTIME_ERROR(format, func_name, args...) \ - scm_error_scm (scm_str2symbol ("gruntime-error"), scm_makfrom0str (func_name), \ - scm_simple_format (SCM_BOOL_F, scm_makfrom0str (format), \ + scm_error_scm (scm_from_locale_symbol ("gruntime-error"), scm_from_locale_string (func_name), \ + scm_simple_format (SCM_BOOL_F, scm_from_locale_string (format), \ scm_list_n (args, SCM_UNDEFINED)), \ SCM_EOL, SCM_EOL) @@ -54,7 +54,7 @@ connect_one (const gchar *handler_name, GObject *object, const gchar *signal_nam proc = GPOINTER_TO_SCM (user_data); scm_call_4 (gtype_instance_signal_connect_data, scm_c_gtype_instance_to_scm (object), - scm_str2symbol (signal_name), + scm_from_locale_symbol (signal_name), proc, after ? SCM_BOOL_T : SCM_BOOL_F); } @@ -72,7 +72,7 @@ _wrap_glade_xml_signal_connect (GladeXML *xml, const char *handlername, SCM proc SCM handle_read_error (char *handler_name, SCM tag, SCM throw_args) { GRUNTIME_ERROR ("Error while reading signal handler ~S: ~A: ~S", - "glade-xml-signal-autoconnect", scm_makfrom0str (handler_name), + "glade-xml-signal-autoconnect", scm_from_locale_string (handler_name), tag, throw_args); } @@ -92,8 +92,8 @@ connect_many (const gchar *handler_name, GObject *object, const gchar *signal_na module); if (SCM_FALSEP (scm_procedure_p (proc))) GRUNTIME_ERROR ("Tried to set `~A' to handle signal `~A', but it's not a procedure", - "glade-xml-signal-autoconnect", scm_makfrom0str (handler_name), - scm_makfrom0str (signal_name)); + "glade-xml-signal-autoconnect", scm_from_locale_string (handler_name), + scm_from_locale_string (signal_name)); connect_one (NULL, object, signal_name, NULL, NULL, after, SCM_TO_GPOINTER (proc)); * libgnome: git 'diff' 'HEAD' * libgnomecanvas: git 'diff' 'HEAD' * libgnomeui: git 'diff' 'HEAD' * pango: git 'diff' 'HEAD' diff --git a/gnome/gw/pango-support.c b/gnome/gw/pango-support.c index 421b68e..e528ec6 100644 --- a/gnome/gw/pango-support.c +++ b/gnome/gw/pango-support.c @@ -31,10 +31,10 @@ scm_pango_rectangle_to_scm (PangoRectangle *rect) { SCM ret = scm_c_make_vector (4, SCM_BOOL_F); - scm_c_vector_set_x (ret, 0, scm_int2num (rect->x)); - scm_c_vector_set_x (ret, 1, scm_int2num (rect->y)); - scm_c_vector_set_x (ret, 2, scm_int2num (rect->width)); - scm_c_vector_set_x (ret, 3, scm_int2num (rect->height)); + scm_c_vector_set_x (ret, 0, scm_from_int (rect->x)); + scm_c_vector_set_x (ret, 1, scm_from_int (rect->y)); + scm_c_vector_set_x (ret, 2, scm_from_int (rect->width)); + scm_c_vector_set_x (ret, 3, scm_from_int (rect->height)); return ret; } @@ -44,7 +44,7 @@ scm_scm_to_pango_rectangle (SCM scm, PangoRectangle* rect) #define FUNC_NAME "%scm->pango-rectangle" { #define GET_VINT(v,i) \ - scm_num2int (scm_c_vector_ref (v, i), 0, FUNC_NAME) + scm_to_int (scm_c_vector_ref (v, i)) rect->x = GET_VINT (scm, 0); rect->y = GET_VINT (scm, 1); * .: git 'diff' 'HEAD'