Index: plug-ins/script-fu/script-fu-scripts.c =================================================================== --- plug-ins/script-fu/script-fu-scripts.c (revision 23413) +++ plug-ins/script-fu/script-fu-scripts.c (working copy) @@ -125,13 +125,6 @@ script_fu_find_scripts (const gchar *pat script_menu_list = NULL; } -static pointer -my_err (scheme *sc, char *msg) -{ - ts_output_string (TS_OUTPUT_ERROR, msg, -1); - return sc->F; -} - pointer script_fu_add_script (scheme *sc, pointer a) { @@ -221,22 +214,22 @@ script_fu_add_script (scheme *sc, pointe if (a != sc->NIL) { if (!sc->vptr->is_integer (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: argument types must be integer values"); + return foreign_error (sc, "script-fu-register: argument types must be integer values", 0); script->arg_types[i] = sc->vptr->ivalue (sc->vptr->pair_car (a)); a = sc->vptr->pair_cdr (a); } else - return my_err (sc, "script-fu-register: missing type specifier"); + return foreign_error (sc, "script-fu-register: missing type specifier", 0); if (a != sc->NIL) { if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: argument labels must be strings"); + return foreign_error (sc, "script-fu-register: argument labels must be strings", 0); script->arg_labels[i] = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); a = sc->vptr->pair_cdr (a); } else - return my_err (sc, "script-fu-register: missing arguments label"); + return foreign_error (sc, "script-fu-register: missing arguments label", 0); if (a != sc->NIL) { @@ -249,7 +242,7 @@ script_fu_add_script (scheme *sc, pointe case SF_VECTORS: case SF_DISPLAY: if (!sc->vptr->is_integer (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: default IDs must be integer values"); + return foreign_error (sc, "script-fu-register: default IDs must be integer values", 0); script->arg_defaults[i].sfa_image = sc->vptr->ivalue (sc->vptr->pair_car (a)); script->arg_values[i].sfa_image = @@ -300,7 +293,7 @@ script_fu_add_script (scheme *sc, pointe if (! gimp_rgb_parse_css (&script->arg_defaults[i].sfa_color, sc->vptr->string_value (sc->vptr->pair_car (a)), -1)) - return my_err (sc, "script-fu-register: invalid default color name"); + return foreign_error (sc, "script-fu-register: invalid default color name", 0); gimp_rgb_set_alpha (&script->arg_defaults[i].sfa_color, 1.0); } @@ -318,7 +311,7 @@ script_fu_add_script (scheme *sc, pointe } else { - return my_err (sc, "script-fu-register: color defaults must be a list of 3 integers or a color name"); + return foreign_error (sc, "script-fu-register: color defaults must be a list of 3 integers or a color name", 0); } script->arg_values[i].sfa_color = script->arg_defaults[i].sfa_color; @@ -330,7 +323,7 @@ script_fu_add_script (scheme *sc, pointe case SF_TOGGLE: if (!sc->vptr->is_integer (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: toggle default must be an integer value"); + return foreign_error (sc, "script-fu-register: toggle default must be an integer value", 0); script->arg_defaults[i].sfa_toggle = (sc->vptr->ivalue (sc->vptr->pair_car (a))) ? TRUE : FALSE; @@ -344,7 +337,7 @@ script_fu_add_script (scheme *sc, pointe case SF_VALUE: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: value defaults must be string values"); + return foreign_error (sc, "script-fu-register: value defaults must be string values", 0); script->arg_defaults[i].sfa_value = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -359,7 +352,7 @@ script_fu_add_script (scheme *sc, pointe case SF_STRING: case SF_TEXT: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: string defaults must be string values"); + return foreign_error (sc, "script-fu-register: string defaults must be string values", 0); script->arg_defaults[i].sfa_value = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -373,7 +366,7 @@ script_fu_add_script (scheme *sc, pointe case SF_ADJUSTMENT: if (!sc->vptr->is_list (sc, a)) - return my_err (sc, "script-fu-register: adjustment defaults must be a list"); + return foreign_error (sc, "script-fu-register: adjustment defaults must be a list", 0); adj_list = sc->vptr->pair_car (a); script->arg_defaults[i].sfa_adjustment.value = @@ -414,12 +407,12 @@ script_fu_add_script (scheme *sc, pointe case SF_FILENAME: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: filename defaults must be string values"); + return foreign_error (sc, "script-fu-register: filename defaults must be string values", 0); /* fallthrough */ case SF_DIRNAME: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: dirname defaults must be string values"); + return foreign_error (sc, "script-fu-register: dirname defaults must be string values", 0); script->arg_defaults[i].sfa_file.filename = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -448,7 +441,7 @@ script_fu_add_script (scheme *sc, pointe case SF_FONT: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: font defaults must be string values"); + return foreign_error (sc, "script-fu-register: font defaults must be string values", 0); script->arg_defaults[i].sfa_font = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -462,7 +455,7 @@ script_fu_add_script (scheme *sc, pointe case SF_PALETTE: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: palette defaults must be string values"); + return foreign_error (sc, "script-fu-register: palette defaults must be string values", 0); script->arg_defaults[i].sfa_palette = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -476,7 +469,7 @@ script_fu_add_script (scheme *sc, pointe case SF_PATTERN: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: pattern defaults must be string values"); + return foreign_error (sc, "script-fu-register: pattern defaults must be string values", 0); script->arg_defaults[i].sfa_pattern = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -490,7 +483,7 @@ script_fu_add_script (scheme *sc, pointe case SF_BRUSH: if (!sc->vptr->is_list (sc, a)) - return my_err (sc, "script-fu-register: brush defaults must be a list"); + return foreign_error (sc, "script-fu-register: brush defaults must be a list", 0); brush_list = sc->vptr->pair_car (a); script->arg_defaults[i].sfa_brush.name = @@ -523,7 +516,7 @@ script_fu_add_script (scheme *sc, pointe case SF_GRADIENT: if (!sc->vptr->is_string (sc->vptr->pair_car (a))) - return my_err (sc, "script-fu-register: gradient defaults must be string values"); + return foreign_error (sc, "script-fu-register: gradient defaults must be string values", 0); script->arg_defaults[i].sfa_gradient = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a))); @@ -537,7 +530,7 @@ script_fu_add_script (scheme *sc, pointe case SF_OPTION: if (!sc->vptr->is_list (sc, a)) - return my_err (sc, "script-fu-register: option defaults must be a list"); + return foreign_error (sc, "script-fu-register: option defaults must be a list", 0); for (option_list = sc->vptr->pair_car (a); option_list != sc->NIL; @@ -559,11 +552,11 @@ script_fu_add_script (scheme *sc, pointe case SF_ENUM: if (!sc->vptr->is_list (sc, a)) - return my_err (sc, "script-fu-register: enum defaults must be a list"); + return foreign_error (sc, "script-fu-register: enum defaults must be a list", 0); option_list = sc->vptr->pair_car (a); if (!sc->vptr->is_string (sc->vptr->pair_car (option_list))) - return my_err (sc, "script-fu-register: first element in enum defaults must be a type-name"); + return foreign_error (sc, "script-fu-register: first element in enum defaults must be a type-name", 0); val = sc->vptr->string_value (sc->vptr->pair_car (option_list)); @@ -576,14 +569,14 @@ script_fu_add_script (scheme *sc, pointe if (! G_TYPE_IS_ENUM (enum_type)) { g_free (val); - return my_err (sc, "script-fu-register: first element in enum defaults must be the name of a registered type"); + return foreign_error (sc, "script-fu-register: first element in enum defaults must be the name of a registered type", 0); } script->arg_defaults[i].sfa_enum.type_name = val; option_list = sc->vptr->pair_cdr (option_list); if (!sc->vptr->is_string (sc->vptr->pair_car (option_list))) - return my_err (sc, "script-fu-register: second element in enum defaults must be a string"); + return foreign_error (sc, "script-fu-register: second element in enum defaults must be a string", 0); enum_value = g_enum_get_value_by_nick (g_type_class_peek (enum_type), @@ -602,8 +595,7 @@ script_fu_add_script (scheme *sc, pointe } else { - return my_err (sc, - "script-fu-register: missing default argument"); + return foreign_error (sc, "script-fu-register: missing default argument", 0); } } } @@ -631,8 +623,7 @@ script_fu_add_menu (scheme *sc, pointer /* Check the length of a */ if (sc->vptr->list_length (sc, a) != 2) - return my_err (sc, - "Incorrect number of arguments for script-fu-menu-register"); + return foreign_error (sc, "Incorrect number of arguments for script-fu-menu-register", 0); /* Find the script PDB entry name */ name = sc->vptr->string_value (sc->vptr->pair_car (a)); Index: plug-ins/script-fu/scheme-wrapper.c =================================================================== --- plug-ins/script-fu/scheme-wrapper.c (revision 23413) +++ plug-ins/script-fu/scheme-wrapper.c (working copy) @@ -565,14 +565,6 @@ convert_string (gchar *str) } } -static pointer -my_err (char *msg, pointer a) -{ - ts_output_string (TS_OUTPUT_ERROR, msg, -1); - return sc.NIL; -} - - /* This is called by the Scheme interpreter to allow calls to GIMP functions */ static pointer marshall_proc_db_call (scheme *sc, pointer a) @@ -631,9 +623,10 @@ g_printerr ("\nIn marshall_proc_db_call /* Make sure there are arguments */ if (a == sc->NIL) - return my_err ("Procedure database argument marshaller was called with no arguments. " - "The procedure to be executed and the arguments it requires " - " (possibly none) must be specified.", sc->NIL); + return foreign_error (sc, + "Procedure database argument marshaller was called with no arguments. " + "The procedure to be executed and the arguments it requires " + " (possibly none) must be specified.", 0); /* The PDB procedure name is the argument or first argument of the list */ if (sc->vptr->is_pair (a)) @@ -667,7 +660,7 @@ g_printerr (" Invalid procedure name\n" #endif g_snprintf (error_str, sizeof (error_str), "Invalid procedure name %s specified", proc_name); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } /* Free the name and the description which are of no use here. */ @@ -692,7 +685,7 @@ g_printerr (" Invalid number of argumen g_snprintf (error_str, sizeof (error_str), "Invalid number of arguments for %s (expected %d but received %d)", proc_name, nparams, (sc->vptr->list_length (sc, a) - 1)); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } /* Marshall the supplied arguments */ @@ -798,7 +791,7 @@ g_printerr (" string arg is '%s'\n" "INT32 vector (argument %d) for function %s has " "size of %ld but expected size of %d", i+1, proc_name, sc->vptr->vector_length (vector), n_elements); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } /* FIXME: Check that g_new returned non-NULL value. */ @@ -814,7 +807,7 @@ g_printerr (" string arg is '%s'\n" g_snprintf (error_str, sizeof (error_str), "Item %d in vector is not a number (argument %d for function %s)\n", j+1, i+1, proc_name); - return my_err (error_str, vector); + return foreign_error (sc, error_str, vector); } args[i].data.d_int32array[j] = @@ -851,7 +844,7 @@ if (count > 0) "INT16 vector (argument %d) for function %s has " "size of %ld but expected size of %d", i+1, proc_name, sc->vptr->vector_length (vector), n_elements); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } args[i].data.d_int16array = g_new (gint16, n_elements); @@ -865,7 +858,7 @@ if (count > 0) g_snprintf (error_str, sizeof (error_str), "Item %d in vector is not a number (argument %d for function %s)\n", j+1, i+1, proc_name); - return my_err (error_str, vector); + return foreign_error (sc, error_str, vector); } args[i].data.d_int16array[j] = @@ -902,7 +895,7 @@ if (count > 0) "INT8 vector (argument %d) for function %s has " "size of %ld but expected size of %d", i+1, proc_name, sc->vptr->vector_length (vector), n_elements); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } args[i].data.d_int8array = g_new (guint8, n_elements); @@ -916,7 +909,7 @@ if (count > 0) g_snprintf (error_str, sizeof (error_str), "Item %d in vector is not a number (argument %d for function %s)\n", j+1, i+1, proc_name); - return my_err (error_str, vector); + return foreign_error (sc, error_str, vector); } args[i].data.d_int8array[j] = @@ -953,7 +946,7 @@ if (count > 0) "FLOAT vector (argument %d) for function %s has " "size of %ld but expected size of %d", i+1, proc_name, sc->vptr->vector_length (vector), n_elements); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } args[i].data.d_floatarray = g_new (gdouble, n_elements); @@ -967,7 +960,7 @@ if (count > 0) g_snprintf (error_str, sizeof (error_str), "Item %d in vector is not a number (argument %d for function %s)\n", j+1, i+1, proc_name); - return my_err (error_str, vector); + return foreign_error (sc, error_str, vector); } args[i].data.d_floatarray[j] = @@ -1004,7 +997,7 @@ if (count > 0) "STRING vector (argument %d) for function %s has " "length of %ld but expected length of %d", i+1, proc_name, sc->vptr->vector_length (vector), n_elements); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } args[i].data.d_stringarray = g_new (gchar *, n_elements); @@ -1018,7 +1011,7 @@ if (count > 0) g_snprintf (error_str, sizeof (error_str), "Item %d in vector is not a string (argument %d for function %s)\n", j+1, i+1, proc_name); - return my_err (error_str, vector); + return foreign_error (sc, error_str, vector); } args[i].data.d_stringarray[j] = @@ -1167,15 +1160,16 @@ g_printerr (" data '%s'\n", (char * break; case GIMP_PDB_STATUS: - return my_err ("Status is for return types, not arguments", - sc->vptr->pair_car (a)); + return foreign_error (sc, + "Status is for return types, not arguments", + sc->vptr->pair_car (a)); break; default: g_snprintf (error_str, sizeof (error_str), "Argument %d for %s is an unknown type", i+1, proc_name); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } /* Break out of loop before i gets updated when error was detected */ @@ -1201,7 +1195,7 @@ g_printerr (" Invalid type for argument g_snprintf (error_str, sizeof (error_str), "Invalid type for argument %d to %s", i+1, proc_name); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } /* Check the return status */ @@ -1214,7 +1208,7 @@ g_printerr (" Did not return status\n") "Procedural database execution of %s did not return a status:\n ", proc_name); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); } #if DEBUG_MARSHALL @@ -1228,14 +1222,14 @@ g_printerr (" return value is %s\n", g_snprintf (error_str, sizeof (error_str), "Procedural database execution of %s failed:\n ", proc_name); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); break; case GIMP_PDB_CALLING_ERROR: g_snprintf (error_str, sizeof (error_str), "Procedural database execution of %s failed on invalid input arguments:\n ", proc_name); - return my_err (error_str, sc->NIL); + return foreign_error (sc, error_str, 0); break; case GIMP_PDB_SUCCESS: @@ -1454,7 +1448,7 @@ g_printerr (" value %d is type %s ( case GIMP_PDB_PARASITE: { if (values[i + 1].data.d_parasite.name == NULL) - return_val = my_err ("Error: null parasite", sc->NIL); + return_val = foreign_error (sc, "Error: null parasite", 0); else { /* don't move the mk_foo() calls outside this function call, @@ -1488,11 +1482,11 @@ g_printerr (" data '%.*s'\n", break; case GIMP_PDB_STATUS: - return my_err ("Procedural database execution returned multiple status values", sc->NIL); + return foreign_error (sc, "Procedural database execution returned multiple status values", 0); break; default: - return my_err ("Unknown return type", sc->NIL); + return foreign_error (sc, "Unknown return type", 0); } } Index: plug-ins/script-fu/tinyscheme/scheme.c =================================================================== --- plug-ins/script-fu/tinyscheme/scheme.c (revision 23413) +++ plug-ins/script-fu/tinyscheme/scheme.c (working copy) @@ -949,6 +949,15 @@ void set_safe_foreign (scheme *sc, point } } +pointer foreign_error (scheme *sc, const char *s, pointer a) { + if (sc->safe_foreign == sc->NIL) { + fprintf (stderr, "set_foreign_error_flag called outside a foreign function\n"); + } else { + sc->foreign_error = cons (sc, mk_string (sc, s), a); + } + return sc->T; +} + /* char_cnt is length of string in chars. */ /* str points to a NUL terminated string. */ @@ -2579,9 +2588,16 @@ static pointer opexe_0(scheme *sc, enum s_goto(sc,procnum(sc->code)); /* PROCEDURE */ } else if (is_foreign(sc->code)) { sc->safe_foreign = cons (sc, sc->NIL, sc->safe_foreign); + sc->foreign_error = sc->NIL; x=sc->code->_object._ff(sc,sc->args); sc->safe_foreign = cdr (sc->safe_foreign); - s_return(sc,x); + if (sc->foreign_error == sc->NIL) { + s_return(sc,x); + } else { + x = sc->foreign_error; + sc->foreign_error = sc->NIL; + Error_1 (sc, string_value (car (x)), cdr (x)); + } } else if (is_closure(sc->code) || is_macro(sc->code) || is_promise(sc->code)) { /* CLOSURE */ /* Should not accept promise */ Index: plug-ins/script-fu/tinyscheme/scheme.h =================================================================== --- plug-ins/script-fu/tinyscheme/scheme.h (revision 23413) +++ plug-ins/script-fu/tinyscheme/scheme.h (working copy) @@ -161,6 +161,7 @@ void putcharacter(scheme *sc, gunicha void putstr(scheme *sc, const char *s); SCHEME_EXPORT void set_safe_foreign (scheme *sc, pointer data); +SCHEME_EXPORT pointer foreign_error (scheme *sc, const char *s, pointer a); #if USE_INTERFACE struct scheme_interface { Index: plug-ins/script-fu/tinyscheme/scheme-private.h =================================================================== --- plug-ins/script-fu/tinyscheme/scheme-private.h (revision 23413) +++ plug-ins/script-fu/tinyscheme/scheme-private.h (working copy) @@ -69,6 +69,7 @@ pointer envir; /* stack regist pointer code; /* register for current code */ pointer dump; /* stack register for next evaluation */ pointer safe_foreign; /* register to avoid gc problems */ +pointer foreign_error; /* used for foreign functions to signal an error */ int interactive_repl; /* are we in an interactive REPL? */ int print_output; /* set to 1 to print results and error messages */