diff --git a/plug-ins/script-fu/Makefile.am b/plug-ins/script-fu/Makefile.am
index bc5e0f829b817fe5712d8035888e47607911ee72..5d477de198b8ccd052071c226ec421e40bc822c1 100644
--- a/plug-ins/script-fu/Makefile.am
+++ b/plug-ins/script-fu/Makefile.am
@@ -88,7 +88,9 @@ script_fu_SOURCES = \
scheme-marshal.c \
scheme-marshal.h \
scheme-wrapper.c \
- scheme-wrapper.h
+ scheme-wrapper.h \
+ script-fu-late-bind.c \
+ script-fu-late-bind.h
LDADD = \
$(libgimpui) \
diff --git a/plug-ins/script-fu/meson.build b/plug-ins/script-fu/meson.build
index 1a2fb4ccb2708c0c4055023af64162a1afce5f44..66b15e05effe901e76c4ae454e15de908a88d5e0 100644
--- a/plug-ins/script-fu/meson.build
+++ b/plug-ins/script-fu/meson.build
@@ -20,7 +20,8 @@ plugin_sources = [
'script-fu-utils.c',
'script-fu.c',
'script-fu-errors.c',
- 'script-fu-compat.c'
+ 'script-fu-compat.c',
+ 'script-fu-late-bind.c'
]
if platform_windows
diff --git a/plug-ins/script-fu/scheme-wrapper.c b/plug-ins/script-fu/scheme-wrapper.c
index 7698e56ec1835101cf8893b21e8e721d05bce198..6cb5dfbd302dd8ae9b325bb4f756a5518516914b 100644
--- a/plug-ins/script-fu/scheme-wrapper.c
+++ b/plug-ins/script-fu/scheme-wrapper.c
@@ -56,16 +56,6 @@ static void ts_init_enum (scheme *sc,
static void ts_init_procedures (scheme *sc,
gboolean register_scipts);
static void convert_string (gchar *str);
-static pointer script_fu_marshal_procedure_call (scheme *sc,
- pointer a,
- gboolean permissive,
- gboolean deprecated);
-static pointer script_fu_marshal_procedure_call_strict (scheme *sc,
- pointer a);
-static pointer script_fu_marshal_procedure_call_permissive (scheme *sc,
- pointer a);
-static pointer script_fu_marshal_procedure_call_deprecated (scheme *sc,
- pointer a);
static pointer script_fu_register_call (scheme *sc,
pointer a);
@@ -142,24 +132,28 @@ void
tinyscheme_init (GList *path,
gboolean register_scripts)
{
- /* init the interpreter */
+ /* init the wrapped interpreter */
if (! scheme_init (&sc))
{
g_warning ("Could not initialize TinyScheme!");
return;
}
+ g_info ("Done initializing wrapped TS interpreter.");
scheme_set_input_port_file (&sc, stdin);
scheme_set_output_port_file (&sc, stdout);
ts_register_output_func (ts_stdout_output_func, NULL);
+ g_info ("Done connecting stdin and stdout to Scheme ports.");
/* Initialize the TinyScheme extensions */
init_ftx (&sc);
script_fu_regex_init (&sc);
+ g_info ("Done initializing TS modules.");
/* register in the interpreter the gimp functions and types. */
ts_init_constants (&sc);
ts_init_procedures (&sc, register_scripts);
+ g_info ("Done defining GIMP functions and enums into TS.");
if (path)
{
@@ -169,8 +163,12 @@ tinyscheme_init (GList *path,
{
gchar *dir = g_file_get_path (list->data);
+ /* Minimal TinyScheme implements a small subset.
+ * Load the scripts that implement more of the Scheme language.
+ */
if (ts_load_file (dir, "script-fu.init"))
{
+ g_info ("Done loading script-fu.init");
/* To improve compatibility with older Script-Fu scripts,
* load script-fu-compat.init from the same directory.
*/
@@ -180,6 +178,7 @@ tinyscheme_init (GList *path,
* load plug-in-compat.init from the same directory.
*/
ts_load_file (dir, "plug-in-compat.init");
+ g_info ("Done loading compatibility .scm scripts");
g_free (dir);
@@ -192,6 +191,7 @@ tinyscheme_init (GList *path,
if (list == NULL)
g_warning ("Unable to read initialization file script-fu.init\n");
}
+ g_info ("Done initialize ScriptFu.");
}
/* Create an SF-RUN-MODE constant for use in scripts.
@@ -403,11 +403,10 @@ static void
ts_init_procedures (scheme *sc,
gboolean register_scripts)
{
- gchar **proc_list;
- gint num_procs;
- gint i;
pointer symbol;
+/* The few foreign functions of ScriptFu that are not calls to the PDB. */
+
#if USE_DL
symbol = sc->vptr->mk_symbol (sc,"load-extension");
sc->vptr->scheme_define (sc, sc->global_env, symbol,
@@ -435,61 +434,6 @@ ts_init_procedures (scheme *sc,
sc->vptr->scheme_define (sc, sc->global_env, symbol,
sc->vptr->mk_foreign_func (sc, script_fu_quit_call));
sc->vptr->setimmutable (symbol);
-
- /* register normal database execution procedure */
- symbol = sc->vptr->mk_symbol (sc, "gimp-proc-db-call");
- sc->vptr->scheme_define (sc, sc->global_env, symbol,
- sc->vptr->mk_foreign_func (sc,
- script_fu_marshal_procedure_call_strict));
- sc->vptr->setimmutable (symbol);
-
- /* register permissive and deprecated db execution procedure; see comment below */
- symbol = sc->vptr->mk_symbol (sc, "-gimp-proc-db-call");
- sc->vptr->scheme_define (sc, sc->global_env, symbol,
- sc->vptr->mk_foreign_func (sc,
- script_fu_marshal_procedure_call_permissive));
- sc->vptr->setimmutable (symbol);
-
- symbol = sc->vptr->mk_symbol (sc, "--gimp-proc-db-call");
- sc->vptr->scheme_define (sc, sc->global_env, symbol,
- sc->vptr->mk_foreign_func (sc,
- script_fu_marshal_procedure_call_deprecated));
- sc->vptr->setimmutable (symbol);
-
- proc_list = gimp_pdb_query_procedures (gimp_get_pdb (),
- ".*", ".*", ".*", ".*",
- ".*", ".*", ".*", ".*",
- &num_procs);
-
- /* Register each procedure as a scheme func */
- for (i = 0; i < num_procs; i++)
- {
- gchar *buff;
-
- /* Build a define that will call the foreign function.
- * The Scheme statement was suggested by Simon Budig.
- *
- * Call the procedure through -gimp-proc-db-call, which is a more
- * permissive version of gimp-proc-db-call, that accepts (and ignores)
- * any number of arguments for nullary procedures, for backward
- * compatibility.
- */
- buff = g_strdup_printf (" (define (%s . args)"
- " (apply -gimp-proc-db-call \"%s\" args))",
- proc_list[i], proc_list[i]);
-
- /* Execute the 'define' */
- sc->vptr->load_string (sc, buff);
-
- g_free (buff);
- }
-
- g_strfreev (proc_list);
-
- /* Register more scheme funcs that call PDB procedures, for compatibility
- * This can overwrite earlier scheme func definitions.
- */
- define_compat_procs (sc);
}
static gboolean
@@ -526,12 +470,12 @@ convert_string (gchar *str)
}
}
+
+
/* Called by the Scheme interpreter on calls to GIMP PDB procedures */
-static pointer
+pointer
script_fu_marshal_procedure_call (scheme *sc,
- pointer a,
- gboolean permissive,
- gboolean deprecated)
+ pointer a)
{
GimpProcedure *procedure;
GimpValueArray *args;
@@ -556,21 +500,57 @@ script_fu_marshal_procedure_call (scheme *sc,
"(possibly none) must be specified.",
0);
- /* The PDB procedure name is the argument or first argument of the list */
+ /* This is a foreign func. In general, "a" is an atom, or list or nil.
+ *
+ * Specific to ScriptFu, the atom or first element of the list is_string, the bound name.
+ * The bound name is a name of a PDB procedure, or a deprecated name.
+ * The rest (if any) of any list are actual args to a called PDB procedure.
+ *
+ * Assert the name is owned by TinyScheme for the lifetime of this invocation,
+ * so we don't need to copy its string value.
+ *
+ * Note that this script may call a PDB procedure that also is a script,
+ * but the interpreter can be reentered.
+ */
if (sc->vptr->is_pair (a))
- proc_name = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+ {
+ proc_name = sc->vptr->string_value (sc->vptr->pair_car (a));
+ /* Skip over procedure name, to the args to the procedure */
+ a = sc->vptr->pair_cdr (a);
+ /* Count the remaining arg list */
+ actual_arg_count = sc->vptr->list_length (sc, a);
+ }
else
- proc_name = g_strdup (sc->vptr->string_value (a));
+ {
+ /* One atom. */
+ proc_name = sc->vptr->string_value (a);
+ actual_arg_count = 0;
+ }
+
+ g_debug ("bound proc name: %s", proc_name);
+ g_debug ("actual arg count: %d", actual_arg_count);
+
+ /* Given proc_name is the bound name, in ScriptFu namespace.
+ * Derive a called name in PDB namespace.
+ * They are the same, unless bound name is deprecated.
+ */
+ {
+ gchar * replacement_name;
+
+ if (is_deprecated (proc_name, &replacement_name) )
+ {
+ g_warning ("PDB procedure name %s is deprecated, please use %s.",
+ proc_name,
+ replacement_name);
- g_debug ("proc name: %s", proc_name);
- g_debug ("parms rcvd: %d", sc->vptr->list_length (sc, a)-1);
+ /* Instead call the replacement. */
+ proc_name = replacement_name;
+ }
+ }
- if (deprecated )
- g_warning ("PDB procedure name %s is deprecated, please use %s.",
- deprecated_name_for (proc_name),
- proc_name);
+ g_debug ("called proc name: %s", proc_name);
- /* report the current command */
+ /* say current command to GIMP user */
script_fu_interface_report_cc (proc_name);
/* Attempt to fetch the procedure from the database */
@@ -584,15 +564,15 @@ script_fu_marshal_procedure_call (scheme *sc,
}
arg_specs = gimp_procedure_get_arguments (procedure, &n_arg_specs);
- actual_arg_count = sc->vptr->list_length (sc, a) - 1;
/* Check the supplied number of arguments.
* This only gives warnings to the console.
* It does not ensure that the count of supplied args equals the count of formal args.
* Subsequent code must not assume that.
*
- * When too few supplied args, when permissive, scriptfu or downstream machinery
- * can try to provide missing args e.g. defaults.
+ * When too few supplied args, be permissive.
+ * Some calls to PDB (i.e. not kind Internal)
+ * can provide missing args e.g. defaults.
*
* Extra supplied args can be discarded.
* Formerly, this was a deprecated behavior depending on "permissive".
@@ -625,20 +605,29 @@ script_fu_marshal_procedure_call (scheme *sc,
pointer vector; /* !!! list or vector */
gint j;
- consumed_arg_count++;
-
- if (consumed_arg_count > actual_arg_count)
+ /* Is the next formal arg beyond actual args? */
+ if ((consumed_arg_count+1) > actual_arg_count)
{
/* Exhausted supplied arguments before formal specs. */
/* Say formal type of first missing arg. */
g_warning ("Missing arg type: %s", g_type_name (G_PARAM_SPEC_VALUE_TYPE (arg_spec)));
+ /* Cannot call Internal kind of PDB procedures because they crash ScriptFu extension.
+ * Other kinds are more forgiving and will provide defaults for missing args.
+ */
+ /* Internal kind have names starting with 'gimp-' */
+ if ( strncmp ( "gimp-", proc_name, strlen ("gimp-")) == 0 )
+ {
+ g_snprintf (error_str, sizeof (error_str),
+ "Too few arguments to internal PDB procedure %s",
+ proc_name);
+ return script_error (sc, error_str, 0);
+ }
+
/* Break loop over formal specs. Continuation is to call PDB with partial args. */
break;
}
- else
- a = sc->vptr->pair_cdr (a); /* advance pointer to next arg in list. */
g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (arg_spec));
@@ -1156,7 +1145,13 @@ script_fu_marshal_procedure_call (scheme *sc,
debug_gvalue (&value);
gimp_value_array_append (args, &value);
g_value_unset (&value);
- }
+
+ /* Advance to next formal arg in Scheme list.
+ * When consumed_arg_count > list length, assert 'a' is nil.
+ */
+ a = sc->vptr->pair_cdr (a);
+ consumed_arg_count++;
+ } /* end for each formal arg */
/* Omit refresh scripts from a script, better than crashing, see #575830. */
if (strcmp (proc_name, "script-fu-refresh") == 0)
@@ -1528,11 +1523,10 @@ script_fu_marshal_procedure_call (scheme *sc,
g_debug ("returning with non-empty result");
}
- g_free (proc_name);
-
/* free executed procedure return values */
gimp_value_array_unref (values);
+ /* FUTURE properly clean up: any errors return without freeing args. */
/* free arguments and values */
gimp_value_array_unref (args);
@@ -1549,26 +1543,11 @@ script_fu_marshal_procedure_call (scheme *sc,
return return_val;
}
-static pointer
-script_fu_marshal_procedure_call_strict (scheme *sc,
- pointer a)
-{
- return script_fu_marshal_procedure_call (sc, a, FALSE, FALSE);
-}
-static pointer
-script_fu_marshal_procedure_call_permissive (scheme *sc,
- pointer a)
-{
- return script_fu_marshal_procedure_call (sc, a, TRUE, FALSE);
-}
-
-static pointer
-script_fu_marshal_procedure_call_deprecated (scheme *sc,
- pointer a)
-{
- return script_fu_marshal_procedure_call (sc, a, TRUE, TRUE);
-}
+/*
+ * The basic foreign (to TS) functions that ScriptFu implements,
+ * that don't call a PDB procedure.
+ */
static pointer
script_fu_register_call (scheme *sc,
diff --git a/plug-ins/script-fu/scheme-wrapper.h b/plug-ins/script-fu/scheme-wrapper.h
index 9ab44efa411564f6462817b8fe766e4b295bc630..3cc1aea423aab2ec63b44afd05f6bcb0fd25582d 100644
--- a/plug-ins/script-fu/scheme-wrapper.h
+++ b/plug-ins/script-fu/scheme-wrapper.h
@@ -44,4 +44,7 @@ void ts_gstring_output_func (TsOutputType type,
int len,
gpointer user_data);
+pointer script_fu_marshal_procedure_call (scheme *sc,
+ pointer a);
+
#endif /* __SCHEME_WRAPPER_H__ */
diff --git a/plug-ins/script-fu/script-fu-compat.c b/plug-ins/script-fu/script-fu-compat.c
index 9a167d396685a72c2307b457562764b9d4c8e848..1234cd57065e15a9c0c0dc0666b17fd1e17f77e5 100644
--- a/plug-ins/script-fu/script-fu-compat.c
+++ b/plug-ins/script-fu/script-fu-compat.c
@@ -168,16 +168,16 @@ define_compat_procs (scheme *sc)
}
}
-/* Return empty string or old_name */
-/* Used for a warning message */
+/* Return empty string or old_name.
+ * Used for a warning message.
+ */
const gchar *
deprecated_name_for (const char *new_name)
{
- gint i;
const gchar * result = empty_string;
/* search values of dictionary/map. */
- for (i = 0; i < G_N_ELEMENTS (compat_procs); i++)
+ for (gint i = 0; i < G_N_ELEMENTS (compat_procs); i++)
{
if (strcmp (compat_procs[i].new_name, new_name) == 0)
{
@@ -186,23 +186,23 @@ deprecated_name_for (const char *new_name)
}
}
return result;
-
}
-/* Not used.
- * Keep for future implementation: catch "undefined symbol" from lisp machine.
+/* Return whether is deprecated, and the new name.
+ * Used for late binding of PDB names.
*/
gboolean
-is_deprecated (const char *old_name)
+is_deprecated (const char *old_name,
+ char **new_name_handle)
{
- gint i;
gboolean result = FALSE;
/* search keys of dictionary/map. */
- for (i = 0; i < G_N_ELEMENTS (compat_procs); i++)
+ for (gint i = 0; i < G_N_ELEMENTS (compat_procs); i++)
{
if (strcmp (compat_procs[i].old_name, old_name) == 0)
{
+ *new_name_handle = compat_procs[i].new_name;
result = TRUE;
break;
}
diff --git a/plug-ins/script-fu/script-fu-compat.h b/plug-ins/script-fu/script-fu-compat.h
index c03c045c6855bfc1c9ac21b6e2b4225b2aa690ca..0e14cc5b64025f0797d3f6b422a22dabdff35afd 100644
--- a/plug-ins/script-fu/script-fu-compat.h
+++ b/plug-ins/script-fu/script-fu-compat.h
@@ -20,7 +20,8 @@
void define_compat_procs (scheme *sc);
-gboolean is_deprecated (const char *old_name);
+gboolean is_deprecated (const char *old_name,
+ char **new_name);
const gchar * deprecated_name_for (const char *new_name);
diff --git a/plug-ins/script-fu/script-fu-late-bind.c b/plug-ins/script-fu/script-fu-late-bind.c
new file mode 100644
index 0000000000000000000000000000000000000000..95357d4c0c1dbc35ac9bb9f77852bc4be1683dd8
--- /dev/null
+++ b/plug-ins/script-fu/script-fu-late-bind.c
@@ -0,0 +1,374 @@
+/* GIMP - The GNU Image Manipulation Program
+ * Copyright (C) 1995 Spencer Kimball and Peter Mattis
+ *
+ * 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 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see .
+ */
+
+
+/*
+ * Implements late binding of calls to a special foreign function.
+ * A mod of TinyScheme.
+ * The mod is special to GIMP.
+ * The special foreign func calls the PDB
+ * i.e. ultimately calls gimp_pdb_run_procedure(procedure name, args)
+ *
+ * This uses more than the usual TinyScheme support for foreign functions.
+ * i.e. we copy certain C definitions from scheme.c
+ * to augment what is in scheme-private.h.
+ * That copied code must be kept in correspondence with the original
+ * (or we could modify TinyScheme further, to export the copied definitions.)
+ */
+
+#include "config.h"
+
+#include
+#include
+
+#include "libgimp/gimp.h"
+
+#include "tinyscheme/scheme-private.h" /* type "scheme" */
+
+#include "scheme-wrapper.h" /* script_fu_marshal_procedure_call */
+#include "script-fu-errors.h" /* G_LOG_DOMAIN */
+#include "script-fu-compat.h" /* is_deprecated */
+#include "script-fu-late-bind.h"
+
+
+/* This section is a hack to avoid touching tinyscheme source.
+ * Which doesn't expose things we need.
+ * !!! Must correspond to definitions in tinyscheme source.
+ */
+ /* C macros not exported by scheme-private.h */
+#define T_ATOM 16384
+#define typeflag(p) ((p)->_flag)
+#define is_atom(p) (typeflag(p)&T_ATOM)
+
+#ifndef USE_SCHEME_STACK
+/* Not exposed by scheme.h */
+struct dump_stack_frame {
+ enum scheme_opcodes op;
+ pointer args;
+ pointer envir;
+ pointer code;
+};
+#endif
+
+
+/* local */
+static void _bind_symbol_to_script_fu_wrapper_foreign_func (scheme *sc,
+ gchar *symbol_name);
+
+static pointer _new_atom_for_bound_string (scheme *sc,
+ pointer binding);
+
+static void _push_onto_dump_args (scheme *sc,
+ pointer value);
+
+static gboolean _is_call_to_PDB (pointer binding);
+static gboolean _procedure_seems_in_PDB_and_not_SF (gchar * symbol_name);
+static gboolean _procedure_seems_in_PDB (gchar * symbol_name);
+
+
+/* We only create a single foreign func, and keep a reference.
+ * The func is foreign to TinyScheme, and wraps all PDB procedures.
+ */
+static pointer script_fu_wrapper_foreign_func=0;
+
+
+
+/*
+ * Given an unbound scheme symbol, try to bind it to a foreign function that calls a PDB procedure.
+ * Also binds deprecated PDB names.
+ *
+ * Formerly scheme-wrapper.c defined all PDB procedure names as symbols, early, at initialization.
+ *
+ * Binding is indirect: to a Scheme foreign function that calls PDB.run_procedure(called_name).
+ *
+ * Returns whether a binding was done.
+ * Side effects on bindings in the global env.
+ */
+gboolean
+try_late_bind_symbol_to_foreign_func (scheme *sc,
+ gchar *symbol_name)
+{
+ gboolean result = FALSE;
+ gchar *new_name;
+
+ if (_procedure_seems_in_PDB_and_not_SF (symbol_name))
+ {
+ /* Name exists in PDB OR is deprecated and a replacement exists in PDB.
+ * When deprecated, the bound foreign function wrapper will convert to new name.
+ * A script usually uses the deprecated name or the new name consistently,
+ * but it could use a mix and this still works, with two separate bindings.
+ */
+ g_info ("Symbol %s bound to PDB.\n", symbol_name);
+ _bind_symbol_to_script_fu_wrapper_foreign_func (sc, symbol_name);
+ result = TRUE;
+ }
+ else
+ {
+ g_info ("Symbol %s not bindable to PDB.\n", symbol_name);
+ result = FALSE;
+ }
+
+ return result;
+}
+
+
+/*
+ * Called while evaluating a symbol.
+ * If the symbol is bound to a special foreign func, evaluate to multiple atoms,
+ * else return the usual bound value of the symbol.
+ * This is not generic to late-binding, but special for ScriptFu:
+ * the bound foreign func needs another argument.
+ *
+ * Expand a binding to a PDB name into two atoms suitable for sc->args.
+ * First atom is a foreign function, the wrapper that calls PDB.
+ * Second atom is a string for the PDB name (extra arg to the wrapper.)
+ *
+ * Side effect on the inner interpreter internals i.e. 'sc'.
+ * First atom, the foreign function, is pushed onto previous frame's args.
+ * Second atom, the bound name, is returned, caller will push onto sc->args.
+ * Note args are temporarily kept in reverse order.
+ *
+ * This is not a Scheme macro, but does alter the normal evaluation.
+ * Maybe it could be implemented more purely as a Scheme macro.
+ */
+pointer
+value_for_binding (scheme * sc,
+ pointer binding)
+{
+ pointer result_value;
+ pointer bound_value;
+
+ /* slot_value_in_env not exported by TinyScheme, equivalent is cdr(binding) */
+ bound_value = pair_cdr (binding);
+
+ if (_is_call_to_PDB (binding))
+ {
+ g_assert (is_foreign (bound_value));
+ _push_onto_dump_args (sc, bound_value);
+
+ /* Result value is bound name.
+ * Return it, caller will push onto dump.args.
+ */
+ result_value = _new_atom_for_bound_string (sc, binding);
+ g_assert (is_atom (result_value));
+ }
+ else
+ {
+ result_value = bound_value;
+ }
+
+ /* Ensure returned value is an atom (fully evaluated), caller will push it onto sc->args.
+ * Ensure (not is_call_to_PDB AND result is bound value)
+ * OR (is_call_to_PDB AND result is_string, AND result is_atom) plus side effect on frame args
+ */
+
+ return result_value;
+}
+
+
+/* local functions */
+
+
+/* Does the given name seem in the PDB?
+ * Seem means:
+ * - deprecated name, which we will translate to a replacement name
+ * - canonically named (looks like a PDB name)
+ *
+ * Not: actually in the PDB.
+ * If not exist, get an error later in foreign function.
+ */
+static gboolean
+_procedure_seems_in_PDB (gchar * symbol_name)
+{
+ gchar * new_name;
+
+ /* Faster to first check deprecated?
+ * Thats a local search O(n) (but could be improved.)
+ * Call to GIMP is relatively expensive.
+ * Then check canonical: must be canonical to be a GIMP name.
+ *
+ * FUTURE query the PDB for all names.
+ * Keep a fast dictionary of existing and deprecated names.
+
+ * Not used, this fails since v3 this requires is_canonical:
+ * && gimp_pdb_procedure_exists (gimp_get_pdb (), symbol_name)
+ */
+
+ return ( is_deprecated (symbol_name, &new_name) ||
+ gimp_is_canonical_identifier (symbol_name));
+ /* Discard new_name. */
+}
+
+
+
+/* Does the given name seem in the PDB,
+ * AND is not a canonically named ScriptFu script
+ * since those are already loaded into the ScriptFu extension
+ * that is, already bound to a Scheme text, not a foreign function.
+ */
+static gboolean
+_procedure_seems_in_PDB_and_not_SF (gchar * symbol_name)
+{
+ /* Faster to first check not have prefix "script-fu"
+ * Call to _procedure_seems_in_PDB is more expensive.
+ */
+ return ((! strncmp ("script-fu", symbol_name, strlen ("script-fu")) == 0) &&
+ _procedure_seems_in_PDB (symbol_name) );
+}
+
+
+/* Is binding from a name seeming in the PDB?
+ * Which will always be to a wrapper foreign function script_fu_marshal_procedure_call.
+ */
+static gboolean
+_is_call_to_PDB (pointer binding)
+{
+ /* A binding in an env is a (symbol . value) pair */
+ pointer bound_value = pair_cdr (binding);
+
+ /* Faster to first check if binding to any foreign func. */
+ if (is_foreign (bound_value) )
+ {
+ pointer bound_symbol = pair_car (binding);
+
+ /* Not every foreign function is a call to the PDB:
+ * 1) script-fu-register etc. is implemented in C code in script-fu-wrapper
+ * 2) script files defining script-fu-foo are read as text into ScriptFu extension,
+ * and ScriptFu interprets them without calling PDB
+ * even though they are also names in the PDB.
+ */
+ return _procedure_seems_in_PDB_and_not_SF (symname (bound_symbol));
+ }
+ else
+ return FALSE;
+}
+
+
+/*
+ * Design alternatives:
+
+ * A call to the PDB goes through one foreign func,
+ * but the foreign func requires the name of the called PDB procedure.
+ *
+ * 1) Bind all symbols calling the PDB to the same wrapper foreign func,
+ * and convey the name of the symbol to the wrapper out of band, i.e. not an arg.
+ *
+ * 2) Bind each symbol to the PDB to its own partial parameterized wrapper foreign func.
+ * i.e. (foo args ) is bound to a small script (-gimp-proc-db-call "foo" args)
+ * That was the previous design.
+ */
+
+
+ /* Bind symbols for PDB procedure names to a same foreign function,
+ * a wrapper that ultimately calls PDB.run_procedure( procedure_name ).
+ */
+static void
+_bind_symbol_to_script_fu_wrapper_foreign_func (scheme *sc,
+ gchar * symbol_name)
+{
+ /* !!! The symbol is not passed separately, but is in the sc. */
+ pointer symbol = sc->code;
+
+ g_info ("late bind symbol %s\n", symbol_name);
+
+ if (!script_fu_wrapper_foreign_func)
+ script_fu_wrapper_foreign_func =
+ sc->vptr->mk_foreign_func (sc, script_fu_marshal_procedure_call);
+
+ /* Symbol already exists. No need to make it. But ensure immutable. */
+ sc->vptr->scheme_define (sc,
+ sc->global_env,
+ symbol,
+ script_fu_wrapper_foreign_func); /* the atom to bind symbol to. */
+ sc->vptr->setimmutable (symbol);
+}
+
+
+/* Make a new string atom, separate but identical to the one in the binding.
+ * A binding is from a string to a value.
+ * Usually evaluation computes an atom from the value.
+ * Here, we new an atom using the bound string.
+ *
+ * FUTURE it might be possible to use the string atom in the binding,
+ * since the binding in the global env will not go away.
+ * Since we are putting it in a list of evaluated args,
+ * which will go out of scope, our copy will get garbage collected.
+ * The one in the binding will never be garbage collected.
+ */
+static pointer
+_new_atom_for_bound_string (scheme * sc,
+ pointer binding)
+{
+ gchar * bound_string;
+
+ /* car of binding is-a symbol.
+ * car of symbol is-a scheme string.
+ * !!! But its not an atom, and we don't own it.
+ */
+ g_assert (is_string (pair_car (pair_car (binding))));
+ /* A scheme string is a cell of a particular type, not a char *. */
+ bound_string = string_value (pair_car (pair_car (binding)));
+ return mk_string (sc, bound_string);
+ /* Result owned by interpreter, to be garbage collected later. */
+}
+
+
+/*
+ * We are in midst of evaluating a symbol.
+ * Prepend given value onto the list of args in evaluation stack in the previous frame.
+ * Only used for special case: insert an arg needed by a foreign function.
+ *
+ * Not pretty, understands too much about the evaluation process.
+ * Ideally, we would not change the history of evaluation.
+ */
+static void
+_push_onto_dump_args (scheme *sc,
+ pointer value)
+{
+
+ /* USE_SCHEME_STACK is a compile time option.
+ * GIMP does use the scheme stack.
+ * Experiments show that not using the scheme stack gains little performance.
+ */
+#ifndef USE_SCHEME_STACK
+ /* sc->dump is declared a "pointer" but stores int count of frames
+ * sc->dump_base is array of dump_stack_frame (i.e. pointer to dump_stack_frame)
+ * dump_stack_frame.args is a list of atoms
+ */
+
+ /* assert there is previous frame at -1 */
+ struct dump_stack_frame *frame;
+ gsize nframes = (int)sc->dump - 1;
+ frame = (struct dump_stack_frame *)sc->dump_base + nframes;
+
+ /* When not USE_SCHEME_STACK, frame is a struct.
+ * frame->args is not a cell, only a pointer to cell.
+ * Pointed to cell is first member of args list.
+ * Replace frame->args with a pointer to first cell of prepended list.
+ */
+ frame->args = cons (sc, value, frame->args);
+
+#else
+ /* When USE_SCHEME_STACK, frame is a list.
+ * sc->dump is the frame.
+ * Second cell of frame is pointer to list of args.
+ * Replace it's car with a pointer to list that is original with prepended value.
+ * Note left side must be an lvalue, that is address of a struct field.
+ */
+ pair_cdr (sc->dump)->_object._cons._car = cons (sc, value, pair_car (pair_cdr (sc->dump)));
+#endif
+}
diff --git a/plug-ins/script-fu/script-fu-late-bind.h b/plug-ins/script-fu/script-fu-late-bind.h
new file mode 100644
index 0000000000000000000000000000000000000000..af0f9e49a8ad09422c9185fb70d450436dd98243
--- /dev/null
+++ b/plug-ins/script-fu/script-fu-late-bind.h
@@ -0,0 +1,27 @@
+/* GIMP - The GNU Image Manipulation Program
+ * Copyright (C) 1995 Spencer Kimball and Peter Mattis
+ *
+ * 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 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see .
+ */
+
+#ifndef __SCRIPT_FU_LATE_BIND_H__
+#define __SCRIPT_FU_LATE_BIND_H__
+
+gboolean try_late_bind_symbol_to_foreign_func (scheme *,
+ gchar *);
+
+pointer value_for_binding (scheme *,
+ pointer);
+
+#endif /* __SCRIPT_FU_LATE_BIND_H__ */
diff --git a/plug-ins/script-fu/script-fu-scripts.c b/plug-ins/script-fu/script-fu-scripts.c
index eac9d0f49d97a48eefa65b07af98ea7583453abd..6f3de5c1359743a488f9726cde9d5d7cde24b466 100644
--- a/plug-ins/script-fu/script-fu-scripts.c
+++ b/plug-ins/script-fu/script-fu-scripts.c
@@ -576,7 +576,12 @@ script_fu_run_command (const gchar *command,
if (ts_interpret_string (command))
{
- g_set_error (error, 0, 0, "%s", output->str);
+ GQuark domain;
+ domain = g_quark_from_static_string ("scriptfu");
+ /* Error message is a string, already formatted,
+ * so use g_set_error_literal instead of g_set_error.
+ */
+ g_set_error_literal (error, domain, 0, output->str);
}
else
{
diff --git a/plug-ins/script-fu/tinyscheme/scheme.c b/plug-ins/script-fu/tinyscheme/scheme.c
index d84f631c0e60cb6058aa33a27b102073f5091827..077e2441931b03521b387f7f2ff86e2fc8c70e8f 100644
--- a/plug-ins/script-fu/tinyscheme/scheme.c
+++ b/plug-ins/script-fu/tinyscheme/scheme.c
@@ -47,10 +47,11 @@
#include
#include
-#include "../script-fu-intl.h"
-
#include "scheme-private.h"
+#include "../script-fu-intl.h"
+#include "../script-fu-late-bind.h"
+
#if !STANDALONE
static ts_output_func ts_output_handler = NULL;
static gpointer ts_output_data = NULL;
@@ -1345,6 +1346,7 @@ static void gc(scheme *sc, pointer a, pointer b) {
if(sc->gc_verbose) {
putstr(sc, "gc...");
}
+ g_info("collect garbage");
/* mark system globals */
mark(sc->oblist);
@@ -2780,14 +2782,40 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
/* fall through */
case OP_REAL_EVAL:
#endif
- if (is_symbol(sc->code)) { /* symbol */
- x=find_slot_in_env(sc,sc->envir,sc->code,1);
- if (x != sc->NIL) {
- s_return(sc,slot_value_in_env(x));
- } else {
- Error_1(sc,"eval: unbound variable:", sc->code);
- }
- } else if (is_pair(sc->code)) {
+ if (is_symbol(sc->code)) /* symbol */
+ {
+ pointer value;
+
+ x = find_slot_in_env (sc, sc->envir, sc->code, 1);
+ if (x != sc->NIL)
+ {
+ /* Original to TS 1.41 : value = slot_value_in_env(x); */
+ value = value_for_binding (sc, x);
+ s_return(sc, value);
+ }
+ else
+ {
+ /* Symbol is unbound */
+ /* Late binding mod of TinyScheme for GIMP ScriptFu. */
+ if (try_late_bind_symbol_to_foreign_func (sc, symname (sc->code)))
+ {
+ /* retry find slot */
+ x = find_slot_in_env (sc, sc->envir, sc->code, 1);
+ if (x != sc->NIL)
+ {
+ value = value_for_binding (sc, x);
+ s_return(sc,value);
+ }
+ else
+ /* Should not happen: we bound it but can't find the binding. */
+ Error_1(sc,"Fail find binding for late bound symbol:", sc->code);
+ }
+ else
+ /* Not late bindable. */
+ Error_1(sc,"eval: unbound variable:", sc->code);
+ }
+ }
+ else if (is_pair(sc->code)) {
if (is_syntax(x = car(sc->code))) { /* SYNTAX */
sc->code = cdr(sc->code);
s_goto(sc,syntaxnum(x));
@@ -2954,6 +2982,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
if (!is_symbol(x)) {
Error_0(sc,"variable is not a symbol");
}
+ g_info("Define %s", symname(x));
s_save(sc,OP_DEF1, sc->NIL, x);
s_goto(sc,OP_EVAL);