callisto-debian/gimp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

plug-ins/script-fu/tinyscheme/scheme.[ch] make it possible for foreign

Browse Source 
2007-08-31  Simon Budig  <simon@gimp.org>

	* plug-ins/script-fu/tinyscheme/scheme.[ch]
	* plug-ins/script-fu/tinyscheme/scheme-private.h: make it possible
	for foreign functions to return an error.

	* plug-ins/script-fu/script-fu-scripts.c
	* plug-ins/script-fu/scheme-wrapper.c: Make use of this.
	Fixes bug #472026.


svn path=/trunk/; revision=23432
This commit is contained in:
Simon Budig
2007-08-31 19:35:26 +00:00
committed by Simon Budig
parent 95f3ed4984
commit 8d42d089ca
6 changed files with 75 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
ChangeLog
View File

@ -1,7 +1,3 @@
2007-08-31 Simon Budig <simon@gimp.org>
* MAINTAINERS: adjusted to enforced gnome-svn standards :-(
2007-08-31 Simon Budig <simon@gimp.org>
* plug-ins/script-fu/tinyscheme/scheme.[ch]
@ -12,6 +8,10 @@
* plug-ins/script-fu/scheme-wrapper.c: Make use of this.
Fixes bug #472026.
2007-08-31 Simon Budig <simon@gimp.org>
* MAINTAINERS: adjusted to enforced gnome-svn standards :-(
2007-08-31 Michael Natterer <mitch@gimp.org>
* app/gui/sync-menu.[ch]: renamed...

60
plug-ins/script-fu/scheme-wrapper.c
View File

@ -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 ()\n");
/* 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 arguments (expected %d but received %d)",
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", args[i].data.d_string);
"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", args[i].data.d_string);
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 *)args[i].data.d_parasite.data);
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 %d\n", i+1);
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 (%d)\n",
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);
}
}

59
plug-ins/script-fu/script-fu-scripts.c
View File

@ -125,13 +125,6 @@ script_fu_find_scripts (const gchar *path)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
}
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
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, pointer a)
}
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 a)
/* 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));

1
plug-ins/script-fu/tinyscheme/scheme-private.h
View File

@ -69,6 +69,7 @@ pointer envir; /* stack register for current environment */
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 */

18
plug-ins/script-fu/tinyscheme/scheme.c
View File

@ -949,6 +949,15 @@ void set_safe_foreign (scheme *sc, pointer data) {
}
}
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 scheme_opcodes op) {
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 */

1
plug-ins/script-fu/tinyscheme/scheme.h
View File

@ -161,6 +161,7 @@ void putcharacter(scheme *sc, gunichar c);
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 {