Initial checkin of Pika from heckimp

plug-ins/script-fu/libscriptfu/README

@@ -0,0 +1,45 @@
+About libscriptfu
+
+libscriptfu is part of PIKA.
+It is not generally useful except by PIKA.
+
+The libscriptfu library is used by plugin executables,
+and the PDB procedures they create,
+all part of the "ScriptFu" machinery.
+
+The libscriptfu library is not intended for third-party developers,
+only for core PIKA developers.
+Headers for libscriptfu might not be installed.
+
+This directory contains three libraries: libscriptfu, tinyscheme, and ftx.
+The tinyscheme library contains a TinyScheme interpreter.
+The ftx library extends the TinyScheme interpreter,
+adding file functions to the Scheme language.
+The libscriptfu library contains both the tinyscheme and ftx libraries.
+The libscriptfu library wraps the TinyScheme interpreter,
+specializing it for PIKA.
+The script-fu executable uses the libscriptfu library,
+to interpret Scheme scripts that PIKA users refer to as "plug-ins."
+
+These libraries depend on other libraries, e.g. math, libpika, glib, etc.
+
+Coupling between the executables and the libraries should be in one direction:
+source for the inner libs should not include headers from the outer executables.
+This lets you more easily update the inner libraries
+(which originated elsewhere and might be maintained elsewhere),
+and change the outer executables
+(which are subject to change by PIKA developers.)
+
+Example (which may change):
+The script-fu executable is a plugin file that implements PDB procedures:
+extension-script-fu, script-fu-console, script-fu-text-console, script-fu-eval,
+and script-fu-server.
+Each of those PDB procedures runs as a separate process.
+Each of those processes uses libscriptfu.
+The main PDB procedure is extension-script-fu, which is a long-lived process.
+It is a PDB procedure of PDBProcedureType EXTENSION.
+It interprets the Scheme scripts that user's call "plug-ins."
+
+Rarely two of the PDB procedure processes run concurrently.
+When they do, and libscriptfu is built as a shared library,
+the read-only, code portion of the library is only loaded in memory once.

plug-ins/script-fu/libscriptfu/ftx/LICENSE

@@ -0,0 +1,31 @@
+                         LICENSE TERMS
+
+(c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+Neither the name of Manuel Heras-Gilsanz nor the names of the
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

plug-ins/script-fu/libscriptfu/ftx/README

@@ -0,0 +1,99 @@
+TinyScheme Extensions (TSX) 1.1  [September, 2002]
+(c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
+
+This software is subject to the license terms contained in the
+LICENSE file.
+
+Changelog:
+1.1 (Sept. 2002) Updated to tinyscheme 1.31
+1.0 (April 2002) First released version
+
+
+WHAT IS TSX?
+
+TinyScheme Extensions is a set of dynamic libraries incorporating
+additional funcionality to TinyScheme, a lightweight
+implementation of the Scheme programming language. TinyScheme
+(http://tinyscheme.sourceforge.net) is maintained by D. Souflis
+(dsouflis@acm.org), and is based on MiniSCHEME version 0.85k4.
+
+Scheme is a very nice and powerful programming language, but the
+basic language is very minimalistic in terms of library functions;
+only basic file input / output functionality is specified.
+Different implementations of the language (MIT Scheme, GUILE,
+Bigloo...) provide their own extension libraries. TSX attempts to
+provide commonly needed functions at a small cost in terms of
+additional program footprint. The library is modularized, so that
+it is possible (and easy!) to select desired functionality via
+#defines in tsx.h.
+
+
+INSTALLATION
+
+TSX has been tested on GNU/Linux 2.4.2 with gcc 2.96 and
+libc-2.2.2, with TinyScheme 1.31.
+
+To install, copy the distribution file to the directory
+where TinyScheme is installed (and where scheme.h lies),
+and run make. If building succeeds, a file called tsx.so
+should be created. This file can be loaded as a TinyScheme
+extension with 
+
+    (load-extension "tsx-1.0/tsx")
+
+After loading TSX, you can make use of its functions.
+To reduce footprint, you can choose the functionality which
+will be included. To do so, have a look at tsx.h and
+comment the #defines for unneeded modules.
+
+If you get compiler errors, make sure you have enabled
+dynamic modules in your tinyscheme runtime (define USE_DL
+somewhere near the top in scheme.h).
+
+
+SAMPLE APPLICATIONS
+
+Three sample applications are distributed with TSX 1.0.
+The code is not particularly elegant, nor written in proper
+functional style, but is provided for illustration of the
+implemented calls.
+
+-smtp.scm
+    Sends an email to the user getting the username from
+    the USER shell variable, connecting to the SMTP port
+    on the local machine.
+
+-listhome.scm
+    Provides a list of all the files on the user's home
+    directory (obtained with the HOME environment variable).
+
+-srepl.scm
+    Provides a socket-based read-eval-print-loop. It listens
+    for connections on the 9000 port of the local machines,
+    and executes the commands received. To test it, run
+
+        telnet localhost 9000
+
+    after starting the sample application, and type Scheme
+    expressions. You will get the evaluations. To exit the
+    session, type "quit" and TinyScheme will exit, closing
+    the socket. The output of some functions will not
+    be the same as you would obtain on TinyScheme's
+    "command line", because standard output is not
+    redirected to the socket, but most commands work ok.
+
+You should copy these applications to the directory where
+TinyScheme is installed (i.e., where the "scheme" binary
+file resides), and can be run with:
+
+    ./scheme listhome.scm
+    ./scheme smtp.scm
+    ./scheme srepl.scm
+
+
+TSX FUNCTIONS
+
+The extension functions implemented by TinyScheme Extensions are
+documented in the file "tsx-functions.txt".
+
+END

plug-ins/script-fu/libscriptfu/ftx/ftx-functions.txt

@@ -0,0 +1,119 @@
+File and Time Extensions for TinyScheme (FTX) 1.0  [August, 2004]
+
+Based on the TinyScheme Extensions (TSX) 1.1  [September, 2002]
+(c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
+
+This software is subject to the license terms contained in the
+LICENSE file.
+
+
+TSX FUNCTIONS
+
+TSX incorporates the following functions:
+
+*File system (included if HAVE_FILESYSTEM is defined in tsx.h)
+
+Scheme already defines functions to read and write files. These
+functions allow access to the filesystem to check if a certain
+file exists, to get its size, etc.
+
+In addition to these functions, a string constant DIR-SEPARATOR
+has been defined. It should be used in scripts which build file
+names that include one or more directories to keep the scripts
+portable to different operating systems.
+
+(file-exists? filename)
+        filename: string
+
+        This function returns #t if the indicated file exists, and
+        #f if it does not exist or if it is not accessible to the
+        requesting user. Accessibility is based on the real user
+        and group ID rather than the effective user ID and group ID.
+
+(file-type filename)
+        filename: string
+
+        This function returns a value based on the file type. It
+        returns FILE_TYPE_FILE (1) for regular files, FILE_TYPE_DIR
+        (2) for directories, and FILE_TYPE_LINK (3) for symbolic
+        links. The value FILE_TYPE_OTHER (0) is returned if the file
+        is of some other type, does not exist, or if the user does
+        not have sufficient privileges to allow the file type to be
+        determined.
+
+(file-size filename)
+        filename: string
+
+        This function returns the size (in bytes) of the
+        indicated file, or #f if the file does not exists or
+        is not accessible to the requesting user.
+
+(file-delete filename)
+        filename: string
+
+        Removes the specified file. It returns #t if the operation
+        succeeds, or #f otherwise (e.g., because the file is
+        read-only, or because the file does not exist).
+
+(dir-open-stream path)
+        path: string
+
+        Opens a "directory stream" on the provided directory path.
+        This stream will provide all the files within the directory,
+        using the function read-dir-entry. The stream should be closed
+        at the end with dir-close-stream.
+
+(dir-read-entry dirstream)
+        dirstream: directory stream, obtained with dir-open-stream.
+
+        It returns the name of the following directory entry, or eof
+        if all the entries were provided. Check the return value with
+        with eof-object?.
+
+(dir-rewind dirstream)
+        dirstream: directory stream, obtained with dir-open-stream.
+
+        Resets the given directory stream. The next call to dir-read-entry
+        will return the first entry again. It returns #t if the operation
+        succeeds, or #f otherwise (ie. dirstream not valid)..
+
+(dir-close-stream dirstream) 
+        dirstream: directory stream, obtained with dir-open-stream.
+
+        Close directory stream. No further calls to read-dir-entry should
+        be performed.
+
+(dir-make dirname . mode)
+       dirname: string
+       mode: integer representing permissions
+
+       Create the directory specified, setting the directory permissions based
+       upon the optional mode argument (taking into account the current
+       umask). If no mode is specified then use the default (umask)
+       permissions. Returns #t if the operation succeeds, otherwise #f.
+       Possible reasons for failure are that the directory already exists,
+       the user is not authorized to create it, or the mode is incorrectly
+       specified).
+
+*Time (available if HAVE_TIME is defined in tsx.h)
+
+(time)
+        Returns the current local time, as a list of integer
+        containing:
+          (year month day-of-month hour min sec millisec)
+        The year is expressed as an offset from 1900.
+
+(gettimeofday)
+        Returns a list containing the number of seconds from
+        the beginning of the day, and microseconds within the
+        current second.
+
+(usleep microsec)
+        microsec: integer
+
+        Suspends execution of the calling thread during the
+        specified number of microseconds.
+
+
+END
+

plug-ins/script-fu/libscriptfu/ftx/ftx.c

@@ -0,0 +1,415 @@
+/* TinyScheme Extensions
+ * (c) 2002 Visual Tools, S.A.
+ * Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
+ *
+ * This software is subject to the terms stated in the
+ * LICENSE file.
+ */
+
+#include "config.h"
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#if HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <time.h>
+
+#include <glib.h>
+
+#include "tinyscheme/scheme-private.h"
+
+#undef cons
+
+typedef enum
+{
+  FILE_TYPE_UNKNOWN = 0, FILE_TYPE_FILE, FILE_TYPE_DIR, FILE_TYPE_LINK
+} FileType;
+
+struct
+named_constant {
+    const char *name;
+    FileType    value;
+};
+
+struct named_constant
+file_type_constants[] = {
+    { "FILE-TYPE-UNKNOWN", FILE_TYPE_UNKNOWN },
+    { "FILE-TYPE-FILE",    FILE_TYPE_FILE },
+    { "FILE-TYPE-DIR",     FILE_TYPE_DIR },
+    { "FILE-TYPE-LINK",    FILE_TYPE_LINK },
+    { NULL, 0 }
+};
+
+pointer foreign_fileexists(scheme *sc, pointer args);
+pointer foreign_filetype(scheme *sc, pointer args);
+pointer foreign_filesize(scheme *sc, pointer args);
+pointer foreign_filedelete(scheme *sc, pointer args);
+pointer foreign_diropenstream(scheme *sc, pointer args);
+pointer foreign_dirreadentry(scheme *sc, pointer args);
+pointer foreign_dirrewind(scheme *sc, pointer args);
+pointer foreign_dirclosestream(scheme *sc, pointer args);
+pointer foreign_mkdir(scheme *sc, pointer args);
+
+pointer foreign_getenv(scheme *sc, pointer args);
+pointer foreign_time(scheme *sc, pointer args);
+pointer foreign_gettimeofday(scheme *sc, pointer args);
+pointer foreign_usleep(scheme *sc, pointer args);
+void    init_ftx (scheme *sc);
+
+
+pointer foreign_fileexists(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  char   *filename;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_string(first_arg))
+    return sc->F;
+
+  filename = sc->vptr->string_value(first_arg);
+  filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
+  if (g_file_test(filename, G_FILE_TEST_EXISTS))
+    return sc->T;
+
+  return sc->F;
+}
+
+pointer foreign_filetype(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  char   *filename;
+  int     retcode;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_string(first_arg))
+    return sc->F;
+
+  filename = sc->vptr->string_value(first_arg);
+  filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
+
+  if (g_file_test(filename, G_FILE_TEST_IS_SYMLINK))
+    retcode =  FILE_TYPE_LINK;
+  else if (g_file_test(filename, G_FILE_TEST_IS_REGULAR))
+    retcode = FILE_TYPE_FILE;
+  else if (g_file_test(filename, G_FILE_TEST_IS_DIR))
+    retcode = FILE_TYPE_DIR;
+  else
+    retcode = FILE_TYPE_UNKNOWN;
+
+  return sc->vptr->mk_integer(sc, retcode);
+}
+
+pointer foreign_filesize(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  pointer ret;
+  struct stat buf;
+  char * filename;
+  int retcode;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_string(first_arg))
+    return sc->F;
+
+  filename = sc->vptr->string_value(first_arg);
+  filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
+  retcode = stat(filename, &buf);
+  if (retcode == 0)
+    ret = sc->vptr->mk_integer(sc,buf.st_size);
+  else
+    ret = sc->F;
+  return ret;
+}
+
+pointer foreign_filedelete(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  pointer ret;
+  char * filename;
+  int retcode;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_string(first_arg)) {
+    return sc->F;
+  }
+
+  filename = sc->vptr->string_value(first_arg);
+  filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
+  retcode = unlink(filename);
+  if (retcode == 0)
+    ret = sc->T;
+  else
+    ret = sc->F;
+  return ret;
+}
+
+pointer foreign_diropenstream(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  char   *dirpath;
+  GDir   *dir;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_string(first_arg))
+    return sc->F;
+
+  dirpath = sc->vptr->string_value(first_arg);
+  dirpath = g_filename_from_utf8 (dirpath, -1, NULL, NULL, NULL);
+
+  dir = g_dir_open(dirpath, 0, NULL);
+  if (dir == NULL)
+    return sc->F;
+
+  /* Stuffing a pointer in a long may not always be portable ~~~~~ */
+  return (sc->vptr->mk_integer(sc, (long) dir));
+}
+
+pointer foreign_dirreadentry(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  GDir   *dir;
+  gchar  *entry;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_integer(first_arg))
+    return sc->F;
+
+  dir = (GDir *) sc->vptr->ivalue(first_arg);
+  if (dir == NULL)
+    return sc->F;
+
+  entry = (gchar *)g_dir_read_name(dir);
+  if (entry == NULL)
+    return sc->EOF_OBJ;
+
+  entry = g_filename_to_utf8 (entry, -1, NULL, NULL, NULL);
+  return (sc->vptr->mk_string(sc, entry));
+}
+
+pointer foreign_dirrewind(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  GDir   *dir;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_integer(first_arg))
+    return sc->F;
+
+  dir = (GDir *) sc->vptr->ivalue(first_arg);
+  if (dir == NULL)
+    return sc->F;
+
+  g_dir_rewind(dir);
+  return sc->T;
+}
+
+pointer foreign_dirclosestream(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  GDir   *dir;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_integer(first_arg))
+    return sc->F;
+
+  dir = (GDir *) sc->vptr->ivalue(first_arg);
+  if (dir == NULL)
+    return sc->F;
+
+  g_dir_close(dir);
+  return sc->T;
+}
+
+pointer foreign_mkdir(scheme *sc, pointer args)
+{
+  pointer     first_arg;
+  pointer     rest;
+  pointer     second_arg;
+  char       *dirname;
+  mode_t      mode;
+  int         retcode;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_string(first_arg))
+    return sc->F;
+  dirname = sc->vptr->string_value(first_arg);
+  dirname = g_filename_from_utf8 (dirname, -1, NULL, NULL, NULL);
+
+  rest = sc->vptr->pair_cdr(args);
+  if (sc->vptr->is_pair(rest)) /* optional mode argument */
+    {
+      second_arg = sc->vptr->pair_car(rest);
+      if (!sc->vptr->is_integer(second_arg))
+        return sc->F;
+      mode = sc->vptr->ivalue(second_arg);
+    }
+  else
+    mode = 0777;
+
+  retcode = g_mkdir(dirname, (mode_t)mode);
+  if (retcode == 0)
+    return sc->T;
+  else
+    return sc->F;
+}
+
+pointer foreign_getenv(scheme *sc, pointer args)
+{
+  pointer     first_arg;
+  pointer     ret;
+  char       *varname;
+  const char *value;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+
+  if (!sc->vptr->is_string(first_arg))
+    return sc->F;
+
+  varname = sc->vptr->string_value(first_arg);
+  value = g_getenv(varname);
+  if (value == NULL)
+    ret = sc->F;
+  else
+    ret = sc->vptr->mk_string(sc,value);
+
+  return ret;
+}
+
+pointer foreign_time(scheme *sc, pointer args)
+{
+  time_t now;
+  struct tm *now_tm;
+  pointer ret;
+
+  if (args != sc->NIL)
+    return sc->F;
+
+  time(&now);
+  now_tm = localtime(&now);
+
+  ret = sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_year),
+         sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_mon),
+          sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_mday),
+           sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_hour),
+            sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_min),
+             sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_sec),sc->NIL))))));
+
+  return ret;
+}
+
+pointer foreign_gettimeofday(scheme *sc, pointer args)
+{
+  pointer ret;
+  gint64  time;
+
+  time = g_get_real_time ();
+
+  ret = sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) time / G_USEC_PER_SEC),
+         sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) time % G_USEC_PER_SEC),
+          sc->NIL));
+
+  return ret;
+}
+
+pointer foreign_usleep(scheme *sc, pointer args)
+{
+  pointer first_arg;
+  long usec;
+
+  if (args == sc->NIL)
+    return sc->F;
+
+  first_arg = sc->vptr->pair_car(args);
+  if (!sc->vptr->is_integer(first_arg))
+    return sc->F;
+
+  usec = sc->vptr->ivalue(first_arg);
+  g_usleep(usec);
+
+  return sc->T;
+}
+
+/* This function gets called when TinyScheme is loading the extension */
+void init_ftx (scheme *sc)
+{
+  int i;
+
+  sc->vptr->scheme_define(sc,sc->global_env,
+                               sc->vptr->mk_symbol(sc,"getenv"),
+                               sc->vptr->mk_foreign_func(sc, foreign_getenv));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"time"),
+                               sc->vptr->mk_foreign_func(sc, foreign_time));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"gettimeofday"),
+                               sc->vptr->mk_foreign_func(sc, foreign_gettimeofday));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"usleep"),
+                               sc->vptr->mk_foreign_func(sc, foreign_usleep));
+
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"file-exists?"),
+                               sc->vptr->mk_foreign_func(sc, foreign_fileexists));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"file-type"),
+                               sc->vptr->mk_foreign_func(sc, foreign_filetype));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"file-size"),
+                               sc->vptr->mk_foreign_func(sc, foreign_filesize));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"file-delete"),
+                               sc->vptr->mk_foreign_func(sc, foreign_filedelete));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"dir-open-stream"),
+                               sc->vptr->mk_foreign_func(sc, foreign_diropenstream));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"dir-read-entry"),
+                               sc->vptr->mk_foreign_func(sc, foreign_dirreadentry));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"dir-rewind"),
+                               sc->vptr->mk_foreign_func(sc, foreign_dirrewind));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"dir-close-stream"),
+                               sc->vptr->mk_foreign_func(sc, foreign_dirclosestream));
+  sc->vptr->scheme_define(sc, sc->global_env,
+                               sc->vptr->mk_symbol(sc,"dir-make"),
+                               sc->vptr->mk_foreign_func(sc, foreign_mkdir));
+
+  for (i = 0; file_type_constants[i].name != NULL; ++i)
+  {
+      sc->vptr->scheme_define(sc, sc->global_env,
+            sc->vptr->mk_symbol(sc, file_type_constants[i].name),
+            sc->vptr->mk_integer(sc, file_type_constants[i].value));
+  }
+}

plug-ins/script-fu/libscriptfu/ftx/ftx.h

@@ -0,0 +1,2 @@
+/* This function gets called when TinyScheme is initializing the extension */
+void init_ftx (scheme *sc);

plug-ins/script-fu/libscriptfu/ftx/listhome.scm

@@ -0,0 +1,58 @@
+; listhome.scm
+; Sample usage of TinyScheme Extension
+; This simple program lists the directory entries on the
+; user's home directory.
+
+; It uses the following TinyScheme Extension functions:
+;    getenv
+;      Used to get HOME environment variable.
+;    open-dir-stream
+;      Used to open directory stream.
+;    read-dir-entry
+;      Used to read directory entries.
+;    close-dir-entry
+;      Used at the end, to close directory stream when done.
+
+; check that extensions are enabled
+(if (not (defined? 'load-extension))
+    (begin
+      (display "TinyScheme has extensions disabled. Enable them!!")
+      (newline)
+      (quit)))
+
+; load TinyScheme extension
+(load-extension "tsx-1.1/tsx")
+
+; check that the necessary functions are available (the user
+; might have removed some functionality...)
+(if (or
+      (not (defined? 'getenv))
+      (not (defined? 'dir-open-stream))
+      (not (defined? 'dir-read-entry))
+      (not (defined? 'dir-close-stream)))
+    (begin
+      (display "Some necessary functions are not available. Exiting!")
+      (newline)
+      (quit)))
+
+; get user's home dir from HOME environment var
+(define homedir (getenv "HOME"))
+(display "Listing contents of ") (display homedir) (newline)
+
+; create directory stream to read dir entries
+(define dirstream (dir-open-stream homedir))
+(if (not dirstream)
+  (begin
+    (display "Unable to open home directory!! Check value of HOME environment var.")
+    (quit)))
+
+(let listentry ((entry (dir-read-entry dirstream)))
+  (if (eof-object? entry)
+    #t
+    (begin
+      (display entry)
+      (newline)
+      (listentry (dir-read-entry dirstream)))))
+
+(dir-close-stream dirstream)
+

plug-ins/script-fu/libscriptfu/ftx/meson.build

@@ -0,0 +1,12 @@
+
+scriptfu_ftx = static_library('scriptfu-ftx',
+  'ftx.c',
+  include_directories: [ rootInclude, libscriptfuInclude, ],
+  dependencies: [
+    glib,
+  ],
+  c_args: [
+    '-DUSE_INTERFACE=1',
+  ],
+  install: false,
+)

plug-ins/script-fu/libscriptfu/meson.build

@@ -0,0 +1,67 @@
+libscriptfuInclude = include_directories('.')
+
+subdir('tinyscheme')
+subdir('ftx')
+
+libscriptfu_sources = [
+  'scheme-wrapper.c',
+  'scheme-marshal.c',
+  'scheme-marshal-return.c',
+  'script-fu-interface.c',
+  'script-fu-regex.c',
+  'script-fu-script.c',
+  'script-fu-scripts.c',
+  'script-fu-utils.c',
+  'script-fu-errors.c',
+  'script-fu-compat.c',
+  'script-fu-lib.c',
+  'script-fu-proc-factory.c',
+  'script-fu-arg.c',
+  'script-fu-register.c',
+  'script-fu-dialog.c',
+  'script-fu-run-func.c',
+  'script-fu-command.c',
+]
+
+# !! just "library(...)" which means shared versus static depends on configuration of project.
+# Meson defaults to shared, but you can reconfigure to static.
+# This library is not generally useful except by core PIKA developers.
+
+# Dependencies:
+# libscriptfu uses Gtk (which libpikaui_dep references)
+# FUTURE: libscriptfu should use libpikaui but not Gtk directly
+# libscriptfu does not use sockets (unlike the outer script-fu or script-fu-server)
+
+# link_whole means the entire ftx and tinyscheme static libraries are in
+# this library, whether or not they are used (see meson docs.)
+
+# FUTURE: install private to pika, in 'lib' subdir parallel to 'modules' subdir
+# Not doing this because it complicates packaging
+# Instead, this library installs in same place as libpika
+# install_dir: pikaplugindir / 'lib',
+
+libscriptfu = library('pika-scriptfu-'+ pika_api_version,
+  libscriptfu_sources,
+  include_directories: [
+    rootInclude,
+    appInclude,
+  ],
+  c_args: [
+    '-DG_LOG_DOMAIN="scriptfu"',
+    '-DSTANDALONE=0',
+    '-DUSE_INTERFACE=1',
+    '-DUSE_STRLWR=0',
+  ],
+  dependencies: [
+    libpikaui_dep,
+    math,
+    gi,
+  ],
+  link_whole: [
+    scriptfu_tinyscheme,
+    scriptfu_ftx,
+  ],
+  vs_module_defs: 'script-fu.def',
+  version: so_version,
+  install: true,
+)

plug-ins/script-fu/libscriptfu/scheme-marshal-return.c

@@ -0,0 +1,619 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+#include "libpika/pika.h"
+#include "tinyscheme/scheme-private.h"
+#include "script-fu-errors.h"
+#include "scheme-marshal.h"
+#include "scheme-marshal-return.h"
+
+/* When include scheme-private.h, must undef cons macro */
+#undef cons
+
+static pointer marshal_PDB_return_by_arity  (scheme         *sc,
+                                             PikaValueArray *values,
+                                             pointer        *error);
+
+static pointer marshal_returned_PDB_values  (scheme         *sc,
+                                             PikaValueArray *values,
+                                             pointer        *error);
+
+static pointer marshal_returned_PDB_value   (scheme        *sc,
+                                             GValue        *value,
+                                             guint          array_length,
+                                             pointer       *error);
+
+
+/* Marshall a GValueArray returned by a PDB procedure.
+ * From a GValueArray into scheme value or error.
+ *
+ * Understands PDB status values.
+ * Delegates most marshalling to marshal_PDB_return_by_arity.
+ * See its doc string.
+ */
+pointer
+marshal_PDB_return (scheme         *sc,
+                    PikaValueArray *values,
+                    gchar          *proc_name,
+                    pointer        *error)
+{
+  gchar   error_str[1024];
+  pointer result = NULL;
+
+  *error = NULL;
+
+  /* caller asserts status value index 0 exists. */
+  switch (PIKA_VALUES_GET_ENUM (values, 0))
+    {
+    case PIKA_PDB_EXECUTION_ERROR:
+      if (pika_value_array_length (values) > 1 &&
+          G_VALUE_HOLDS_STRING (pika_value_array_index (values, 1)))
+        {
+          g_snprintf (error_str, sizeof (error_str),
+                      "Procedure execution of %s failed: %s",
+                      proc_name,
+                      PIKA_VALUES_GET_STRING (values, 1));
+        }
+      else
+        {
+          g_snprintf (error_str, sizeof (error_str),
+                      "Procedure execution of %s failed",
+                      proc_name);
+        }
+        /* not language errors, procedure returned error for unknown reason. */
+      *error = foreign_error (sc, error_str, 0);
+      break;
+
+    case PIKA_PDB_CALLING_ERROR:
+      if (pika_value_array_length (values) > 1 &&
+          G_VALUE_HOLDS_STRING (pika_value_array_index (values, 1)))
+        {
+          g_snprintf (error_str, sizeof (error_str),
+                      "Procedure execution of %s failed on invalid input arguments: %s",
+                      proc_name,
+                      PIKA_VALUES_GET_STRING (values, 1));
+        }
+      else
+        {
+          g_snprintf (error_str, sizeof (error_str),
+                      "Procedure execution of %s failed on invalid input arguments",
+                      proc_name);
+        }
+      /* not language errors, PIKA validated the GValueArray
+       * and decided it doesn't match the registered signature
+       * or the procedure decided its preconditions not met (e.g. out of range)
+       */
+      *error = foreign_error (sc, error_str, 0);
+      break;
+
+    case PIKA_PDB_SUCCESS:
+      {
+        pointer marshalling_error;
+
+        result = marshal_PDB_return_by_arity (sc, values, &marshalling_error);
+        if (marshalling_error != NULL)
+          {
+            /* Error marshalling set of values.
+             * Any scheme values already marshalled will be garbage collected.
+             */
+            /* Propagate. */
+            *error = marshalling_error;
+            g_assert (result == NULL);
+          }
+        /* else assert result is not NULL but can be sc->NIL */
+      }
+      break;
+
+    case PIKA_PDB_PASS_THROUGH:
+      /* Should not happen. No plugin in the repo returns this.
+       * See app/pdb/pika-pdb.c for what little doc there is.
+       * It says there the result should be discarded
+       * in lieu of the subsequent procedure's result.
+       * */
+      g_warning ("Status is PASS_THROUGH, not handled properly.");
+      result = sc->vptr->cons (sc, sc->F, sc->NIL);
+
+    case PIKA_PDB_CANCEL:
+      /* A PDB procedure called interactively showed a dialog which the user cancelled. */
+      g_debug ("cancelled PDB proc returns (#f)");
+      /* A scheme function must return a value.
+       * Return false to indicate canceled. But is not an error.
+       *
+       * This is moot because you can't call a plugin interactively from a script anyway.
+       * (Top level scripts can be called interactively.)
+       *
+       * FUTURE: (when a script can call another script passing run mode INTERACTIVE)
+       * A well written script should not call PDB procedure interactively (cancelable)
+       * without checking whether the result is just #f or the expected value signature.
+       * No PDB procedure returning boolean should be called interactively from ScriptFu
+       * since you can't distinguish canceled from another false result.
+       * You can call such a procedure only for its side effects, if you ignore the result.
+       */
+      /* Returning (#f),
+       * FUTURE: return only #f, no reason to wrap.
+       */
+      result = sc->vptr->cons (sc, sc->F, sc->NIL);
+      break;
+    } /* end switch on PDB status. */
+
+  g_assert (   (result == NULL && *error != NULL)
+            || (result != NULL && *error == NULL));
+  return result;
+}
+
+
+/* Marshall a GValueArray returned by a PDB procedure.
+ * From a GValueArray into scheme value.
+ *
+ * Understands the return arity of PDB procedures.
+ *
+ * Returns a scheme "pointer" type referencing the scheme return value.
+ *
+ * The return value is a list.
+ * FUTURE: value is either a single value or a list.
+ *
+ * Same error return as marshal_returned_PDB_values.
+ */
+pointer
+marshal_PDB_return_by_arity (scheme         *sc,
+                             PikaValueArray *values,
+                             pointer        *error)
+{
+  /* NULL, not defaulting to sc->NIL. */
+  pointer result = NULL;
+  pointer marshalling_error = NULL;
+  gint   return_arity;
+
+  *error = NULL;
+
+  /* values has an extra status value over the return arity of the procedure.
+   * This is actual signature of the returned values.
+   * Could compare with the declared formal signature.
+   */
+  return_arity = pika_value_array_length (values) - 1;
+
+  /* Require caller ensured there is a status value. */
+  g_assert (return_arity >= 0);
+
+  if (return_arity == 0)
+    {
+      /* PDB procedure returns void.
+       * Every scheme function must return a value.
+       * Return (#t)
+       * FUTURE: return just sc->T, no reason to wrap it.
+       * result = sc->T;
+       */
+      g_debug ("void PDB proc returns (#t)");
+      result = sc->vptr->cons (sc, sc->T, sc->NIL);
+    }
+  else if (return_arity == 1)
+    {
+      /* Unary result.
+       * Return a list wrapping the result.
+       * FUTURE: return just unwrapped result (which can itself be a list.)
+       * i.e. just call marshal_returned_PDB_value (singular)
+       */
+      result = marshal_returned_PDB_values (sc, values, &marshalling_error);
+      if (marshalling_error != NULL)
+        {
+          /* Propagate error. */
+          *error = marshalling_error;
+        }
+    }
+  else /* >1 */
+    {
+      /* Many result values.
+       * Return a list wrapping the results. Similar to Python tuple return.
+       */
+      result = marshal_returned_PDB_values (sc, values, &marshalling_error);
+      if (marshalling_error != NULL)
+        {
+          /* Propagate error. */
+          *error = marshalling_error;
+        }
+    }
+  g_assert (   (result == NULL && *error != NULL)
+            || (result != NULL && *error == NULL));
+  /* result is: (#t) or sc->NIL i.e. empty list or a non-empty list. */
+  /* FUTURE result is: #t or an atom or a vector
+   * or empty list or a non-empty list.
+   * A non-empty list is either a single result that itself is a list
+   * or a list wrapping a multiple result.
+   */
+  return result;
+}
+
+
+/* Marshall a set of values returned by a PDB procedure.
+ * From a GValueArray into scheme list.
+ *
+ * Returns a scheme "pointer" type referencing the scheme list.
+ *
+ * Either returns a non-null scheme value and sets error to null,
+ * or sets error and returns a null scheme value.
+ * IOW, error is an OUT argument.
+ *
+ * The returned scheme value is scheme type list.
+ * The list can be non-homogenous (elements of different scheme types.)
+ *
+ * The returned list may be empty or have only a single element.
+ * FUTURE:
+ * When a PDB procedure returns a single value (which can be a container)
+ * do not wrap it in a list.
+ * It will be an error to call this function
+ * for PDB procedures that return a single value or return void.
+ * IOW, for PDB procedures of return arity < 2.
+ */
+static pointer
+marshal_returned_PDB_values (scheme         *sc,
+                             PikaValueArray *values,
+                             pointer        *error)
+{
+  /* Result is empty list. */
+  pointer result = sc->NIL;
+
+  *error = NULL;
+
+  /* Counting down, i.e. traversing in reverse.
+  * i+1 is the current index.  i is the preceding value.
+  * When at the current index is an array, preceding value (at i) is array length.
+  */
+  for (gint i = pika_value_array_length (values) - 2; i >= 0; --i)
+    {
+      GValue *value = pika_value_array_index (values, i + 1);
+      pointer scheme_value;
+      pointer single_error = NULL;
+      gint32  array_length = 0;
+
+      g_debug ("Return value %d is type %s", i+1, G_VALUE_TYPE_NAME (value));
+
+      /* In some cases previous value is array_length. */
+      if (   PIKA_VALUE_HOLDS_INT32_ARRAY (value)
+          || PIKA_VALUE_HOLDS_FLOAT_ARRAY (value)
+          || PIKA_VALUE_HOLDS_RGB_ARRAY   (value))
+        {
+          array_length = PIKA_VALUES_GET_INT (values, i);
+        }
+
+      scheme_value = marshal_returned_PDB_value (sc, value, array_length, &single_error);
+
+      if (single_error == NULL)
+        {
+          /* Prepend to scheme list of returned values and continue iteration. */
+          result = sc->vptr->cons (sc, scheme_value, result);
+        }
+      else
+        {
+          /* Error marshalling a single return value.
+          * Any scheme values already marshalled will be garbage collected.
+          */
+          /* Propagate error to caller. */
+          *error = single_error;
+          /* null C pointer not the same as pointer to scheme NIL */
+          result = NULL;
+          break;
+        }
+    }
+
+  g_assert (   (result == NULL && *error != NULL)
+            || (result != NULL && *error == NULL));
+  /* result can be sc->NIL i.e. empty list. */
+  return result;
+}
+
+
+
+/* The below code for array results is not safe.
+ * It implicitly requires, but does not explicitly check,
+ * that the returned length equals the actual length of the returned array,
+ * and iterates over the returned array assuming it has the returned length.
+ * It could read past the end of the array.
+ */
+
+/* Convert a GValue from C type to Scheme type.
+ *
+ * Returns a scheme "pointer" type referencing the scheme value.
+ *
+ * When the value has C type an array type,
+ * array_length must be its length,
+ * otherwise array_length is not used.
+ *
+ * Either returns a non-null scheme value and sets error to null,
+ * or sets error and returns a null scheme value.
+ * IOW, error is an OUT argument.
+ *
+ * The returned scheme value is an atom or a container (list or vector.)
+ * Returned containers are homogeneous (elements all the same type.)
+ * Returned atoms are scheme type number or string.
+ * Currently, does not return atoms of scheme type byte or char
+ * (no PDB procedure returns those types.)
+ *
+ * !!! Returns a scheme number (0 or 1) for C type boolean.
+ * FUTURE: return atoms #f and #t.
+ */
+static pointer
+marshal_returned_PDB_value    (scheme        *sc,
+                               GValue        *value,
+                               guint          array_length,
+                               pointer       *error)
+{
+  pointer  result = sc->NIL;
+  gint     j;
+  gchar    error_str[1024];
+
+  *error = NULL;
+
+  /* Order is important.
+    * GFile before other objects.
+    * PIKA Image, Drawable, etc. objects.
+    * Alternatively, more specific tests.
+    */
+  if (G_VALUE_TYPE (value) == G_TYPE_FILE)
+    {
+      gchar *parsed_filepath = marshal_returned_gfile_to_string (value);
+
+      if (parsed_filepath)
+        {
+          g_debug ("PDB procedure returned GFile '%s'", parsed_filepath);
+          /* copy string into interpreter state. */
+          result = sc->vptr->mk_string (sc, parsed_filepath);
+          g_free (parsed_filepath);
+        }
+      else
+        {
+          g_warning ("PDB procedure failed to return a valid GFile");
+          result = sc->vptr->mk_string (sc, "");
+        }
+      /* Ensure result holds a string, possibly empty. */
+    }
+  else if (G_VALUE_HOLDS_OBJECT (value))
+    {
+      /* G_VALUE_HOLDS_OBJECT only ensures value derives from GObject.
+        * Could be a PIKA or a GLib type.
+        * Here we handle PIKA types, which all have an id property.
+        * Resources, Images, Drawables etc. have an int ID.
+        */
+      GObject *object = g_value_get_object (value);
+      gint     id     = -1;
+
+      /* expect a PIKA opaque object having an "id" property */
+      if (object)
+        g_object_get (object, "id", &id, NULL);
+
+      /* id is -1 when the gvalue had no GObject*,
+        * or the referenced object had no property "id".
+        * This can be an undetected fault in the called procedure.
+        * It is not necessarily an error in the script.
+        */
+      if (id == -1)
+        g_warning ("PDB procedure returned NULL PIKA object.");
+
+      g_debug ("PDB procedure returned object ID: %i", id);
+
+      /* Scriptfu stores object IDs as int. */
+      result = sc->vptr->mk_integer (sc, id);
+    }
+  else if (G_VALUE_HOLDS_INT (value))
+    {
+      gint v = g_value_get_int (value);
+      result = sc->vptr->mk_integer (sc, v);
+    }
+  else if (G_VALUE_HOLDS_UINT (value))
+    {
+      guint v = g_value_get_uint (value);
+      result = sc->vptr->mk_integer (sc, v);
+    }
+  else if (G_VALUE_HOLDS_DOUBLE (value))
+    {
+      gdouble v = g_value_get_double (value);
+      result = sc->vptr->mk_real (sc, v);
+    }
+  else if (G_VALUE_HOLDS_ENUM (value))
+    {
+      gint v = g_value_get_enum (value);
+      result = sc->vptr->mk_integer (sc, v);
+    }
+  else if (G_VALUE_HOLDS_BOOLEAN (value))
+    {
+      gboolean v = g_value_get_boolean (value);
+      result = sc->vptr->mk_integer (sc, v);
+    }
+  else if (G_VALUE_HOLDS_STRING (value))
+    {
+      const gchar *v = g_value_get_string (value);
+
+      if (! v)
+        v = "";
+
+      result = sc->vptr->mk_string (sc, v);
+    }
+  else if (PIKA_VALUE_HOLDS_INT32_ARRAY (value))
+    {
+      const gint32 *v      = pika_value_get_int32_array (value);
+      pointer       vector = sc->vptr->mk_vector (sc, array_length);
+
+      for (j = 0; j < array_length; j++)
+        {
+          sc->vptr->set_vector_elem (vector, j,
+                                      sc->vptr->mk_integer (sc, v[j]));
+        }
+
+      result = vector;
+    }
+  else if (G_VALUE_HOLDS (value, G_TYPE_BYTES))
+    {
+      GBytes       *v_bytes  = g_value_get_boxed (value);
+      const guint8 *v        = g_bytes_get_data (v_bytes, NULL);
+      gsize         n        = g_bytes_get_size (v_bytes);
+      pointer       vector   = sc->vptr->mk_vector (sc, n);
+
+      for (j = 0; j < n; j++)
+        {
+          sc->vptr->set_vector_elem (vector, j,
+                                      sc->vptr->mk_integer (sc, v[j]));
+        }
+
+      result = vector;
+    }
+  else if (PIKA_VALUE_HOLDS_FLOAT_ARRAY (value))
+    {
+      const gdouble *v      = pika_value_get_float_array (value);
+      pointer        vector = sc->vptr->mk_vector (sc, array_length);
+
+      for (j = 0; j < array_length; j++)
+        {
+          sc->vptr->set_vector_elem (vector, j,
+                                      sc->vptr->mk_real (sc, v[j]));
+        }
+
+      result = vector;
+    }
+  else if (G_VALUE_HOLDS (value, G_TYPE_STRV))
+    {
+      gint32         n    = 0;
+      const gchar  **v    = g_value_get_boxed (value);
+      pointer        list = sc->NIL;
+
+      n = (v)? g_strv_length ((char **) v) : 0;
+      for (j = n - 1; j >= 0; j--)
+        {
+          list = sc->vptr->cons (sc,
+                                  sc->vptr->mk_string (sc,
+                                                      v[j] ?
+                                                      v[j] : ""),
+                                  list);
+        }
+
+      result = list;
+    }
+  else if (PIKA_VALUE_HOLDS_RGB (value))
+    {
+      PikaRGB  v;
+      guchar   r, g, b;
+      gpointer temp_val;
+
+      pika_value_get_rgb (value, &v);
+      pika_rgb_get_uchar (&v, &r, &g, &b);
+
+      temp_val = sc->vptr->cons
+                    (sc,
+                    sc->vptr->mk_integer (sc, r),
+                    sc->vptr->cons
+                      (sc,
+                        sc->vptr->mk_integer (sc, g),
+                        sc->vptr->cons
+                          (sc,
+                          sc->vptr->mk_integer (sc, b),
+                          sc->NIL)));
+
+      result = temp_val;
+    }
+  else if (PIKA_VALUE_HOLDS_RGB_ARRAY (value))
+    {
+      const PikaRGB  *v = pika_value_get_rgb_array (value);
+      pointer  vector   = sc->vptr->mk_vector (sc, array_length);
+
+      for (j = 0; j < array_length; j++)
+        {
+          guchar  r, g, b;
+          pointer temp_val;
+
+          pika_rgb_get_uchar (&v[j], &r, &g, &b);
+
+          temp_val = sc->vptr->cons
+                      (sc,
+                        sc->vptr->mk_integer (sc, r),
+                        sc->vptr->cons
+                          (sc,
+                          sc->vptr->mk_integer (sc, g),
+                          sc->vptr->cons
+                            (sc,
+                              sc->vptr->mk_integer (sc, b),
+                              sc->NIL)));
+          sc->vptr->set_vector_elem (vector, j, temp_val);
+        }
+
+      result = vector;
+    }
+  else if (PIKA_VALUE_HOLDS_PARASITE (value))
+    {
+      PikaParasite *v = g_value_get_boxed (value);
+
+      if (v->name == NULL)
+        {
+          /* Wrongly passed a Parasite that appears to be null, or other error. */
+          *error = implementation_error (sc, "Error: null parasite", 0);
+        }
+      else
+        {
+          gchar   *data = g_strndup (v->data, v->size);
+          gint     char_cnt = g_utf8_strlen (data, v->size);
+          pointer  temp_val;
+
+          /* don't move the mk_foo() calls outside this function call,
+            * otherwise they might be garbage collected away!
+            */
+          temp_val = sc->vptr->cons
+                        (sc,
+                        sc->vptr->mk_string (sc, v->name),
+                        sc->vptr->cons
+                          (sc,
+                            sc->vptr->mk_integer (sc, v->flags),
+                            sc->vptr->cons
+                              (sc,
+                              sc->vptr->mk_counted_string (sc,
+                                                            data,
+                                                            char_cnt),
+                              sc->NIL)));
+
+          result = temp_val;
+          g_free (data);
+
+          g_debug ("name '%s'", v->name);
+          g_debug ("flags %d", v->flags);
+          g_debug ("size %d", v->size);
+          g_debug ("data '%.*s'", v->size, (gchar *) v->data);
+        }
+    }
+  else if (PIKA_VALUE_HOLDS_OBJECT_ARRAY (value))
+    {
+      result = marshal_returned_object_array_to_vector (sc, value);
+    }
+  else if (G_VALUE_TYPE (&value) == PIKA_TYPE_PDB_STATUS_TYPE)
+    {
+      /* Called procedure implemented incorrectly. */
+      *error = implementation_error (sc, "Procedure execution returned multiple status values", 0);
+    }
+  else
+    {
+      /* Missing cases here. */
+      g_snprintf (error_str, sizeof (error_str),
+                  "Unhandled return type %s",
+                  G_VALUE_TYPE_NAME (value));
+      *error = implementation_error (sc, error_str, 0);
+    }
+
+  g_assert (   (result == NULL && *error != NULL)
+            || (result != NULL && *error == NULL));
+
+  return result;
+}

plug-ins/script-fu/libscriptfu/scheme-marshal-return.h

@@ -0,0 +1,30 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCHEME_MARSHAL_RETURN_H__
+#define __SCHEME_MARSHAL_RETURN_H__
+
+pointer marshal_PDB_return    (scheme         *sc,
+                               PikaValueArray *values,
+                               gchar          *proc_name,
+                               pointer        *error);
+
+#endif /* __SCHEME_MARSHAL_RETURN_H__ */

plug-ins/script-fu/libscriptfu/scheme-marshal.c

@@ -0,0 +1,237 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+#include "libpika/pika.h"
+#include "tinyscheme/scheme-private.h"
+#include "scheme-marshal.h"
+#include "script-fu-errors.h"
+
+
+/*
+ * Marshal arguments to, and return values from, calls to PDB.
+ * Convert Scheme constructs to/from a GValue.
+ *
+ * For each marshalling function:
+ *   - a returned "pointer" is a scheme pointer to a foreign error or NULL.
+ *   - marshal into a GValue holding a designated type,
+ *     usually a PIKA type but also GLib types, e.g. GFile.
+ *     The GValue's held type is already set, but value is uninitialized.
+ *
+ * When marshalling into a PikaObjectArray, arbitrarily say the contained type is PIKA_TYPE_DRAWABLE.
+ * The actual contained type is opaque to the PDB calling mechanism.
+ * Setting the GValue's value does not check the contained type.
+ * But we do call pika_drawable_get_by_id.
+ * PIKA_TYPE_DRAWABLE is a superclass of most common uses.
+ * But perhaps we should call pika_item_get_by_id
+ * and arbitrarily say PIKA_TYPE_ITEM, a superclass of drawable.
+ */
+
+
+
+
+/* Marshal single drawable ID from script into a single GObject. */
+pointer
+marshal_ID_to_drawable (scheme   *sc,
+                        pointer   a,
+                        gint      id,
+                        GValue   *value)
+{
+  PikaDrawable *drawable;
+
+  pointer error = get_drawable_from_script (sc, a, id, &drawable);
+  if (error)
+    return error;
+
+  /* drawable is NULL or valid */
+
+  /* Shallow copy, adding a reference while the GValue exists. */
+  g_value_set_object (value, drawable);
+  return NULL;  /* no error */
+}
+
+/* Marshal a vector of ID into PikaObjectArray of same length. */
+pointer
+marshal_vector_to_drawable_array (scheme   *sc,
+                                  pointer   vector,
+                                  GValue   *value)
+{
+  PikaDrawable **drawable_array;
+  gint           id;
+  pointer        error;
+
+  guint num_elements = sc->vptr->vector_length (vector);
+  g_debug ("vector has %d elements", num_elements);
+  /* empty vector will produce empty PikaObjectArray */
+
+  drawable_array = g_new0 (PikaDrawable*, num_elements);
+
+  for (int j = 0; j < num_elements; ++j)
+    {
+      pointer element = sc->vptr->vector_elem (vector, j);
+
+      if (!sc->vptr->is_number (element))
+        {
+          g_free (drawable_array);
+          return script_error (sc, "Expected numeric in drawable vector", vector);
+          /* FUTURE more detailed error msg:
+           * return script_type_error_in_container (sc, "numeric", i, j, proc_name, vector);
+           */
+        }
+
+      id = sc->vptr->ivalue (element);
+      error = get_drawable_from_script (sc, element, id, &drawable_array[j]);
+      if (error)
+        {
+          g_free (drawable_array);
+          return error;
+        }
+    }
+
+  /* Shallow copy. */
+  pika_value_set_object_array (value, PIKA_TYPE_DRAWABLE, (GObject**)drawable_array, num_elements);
+
+  g_free (drawable_array);
+
+  return NULL;  /* no error */
+}
+
+
+/* Marshal path string from script into a GValue holding type GFile */
+void
+marshal_path_string_to_gfile (scheme     *sc,
+                              pointer     a,
+                              GValue     *value)
+{
+  /* require sc->vptr->is_string (sc->vptr->pair_car (a)) */
+
+  GFile *gfile = g_file_new_for_path (sc->vptr->string_value (sc->vptr->pair_car (a)));
+  /* GLib docs say that g_file_new_for_path():
+   * "never fails, but the returned object might not support any I/O operation if path is malformed."
+   */
+
+  g_value_set_object (value, gfile);
+  g_debug ("gfile arg is '%s'\n", g_file_get_parse_name (gfile));
+}
+
+
+/* Marshal values returned from PDB call in a GValue, into a Scheme construct to a script. */
+
+
+/* Marshal a GValue holding a GFile into a string.
+ *
+ * Returns NULL or a string that must be freed.
+ */
+ gchar *
+ marshal_returned_gfile_to_string (GValue   *value)
+{
+  gchar * filepath = NULL;
+
+  GObject *object = g_value_get_object (value);
+  /* object can be NULL, the GValue's type only indicates what should have been returned. */
+  if (object)
+    {
+      filepath = g_file_get_parse_name ((GFile *) object);
+      /* GLib docs:
+       * For local files with names that can safely be converted to UTF-8 the pathname is used,
+       * otherwise the IRI is used (a form of URI that allows UTF-8 characters unescaped).
+       */
+     }
+  return filepath;
+}
+
+
+/* Marshal a PikaObjectArray into a Scheme list of ID's.
+ *
+ * Before v3.0, PDB procedure's return type was say INT32ARRAY,
+ * preceded by a type INT32 designating array length.
+ * Now return type is PikaObjectArray preceded by length.
+ *
+ * Returns a vector, since most arrays in Scriptfu are returned as vectors.
+ * An alternate implementation would be return list.
+ *
+ * Existing scheme plugins usually expect PDB to return values: len, vector.
+ * If ever the PDB is changed to be more object-oriented,
+ * scripts could use a scheme call: (vector-length vector)
+ * to get the length of the vector.
+ */
+pointer
+marshal_returned_object_array_to_vector (scheme   *sc,
+                                         GValue   *value)
+{
+  GObject **object_array;
+  gint32    n;
+  pointer   vector;
+
+  object_array = pika_value_get_object_array (value);
+  /* array knows own length, ignore length in preceding return value */
+  n = ((PikaObjectArray*)g_value_get_boxed (value))->length;
+
+  vector = sc->vptr->mk_vector (sc, n);
+
+  /* Iterate starting at the back of the array, and prefix to container
+   * so the order of objects is not changed.
+   */
+  for (int j = n - 1; j >= 0; j--)
+    {
+      GObject *object = object_array[j];
+      gint     id;
+
+      if (object)
+        g_object_get (object, "id", &id, NULL); /* get property "id" */
+      else
+        /* Scriptfu language represents NULL object by ID of -1*/
+        id = -1;
+
+      sc->vptr->set_vector_elem (vector, j, sc->vptr->mk_integer (sc, id));
+      /* Alt: list = sc->vptr->cons (sc, sc->vptr->mk_integer (sc, id), list); */
+    }
+  /* ensure container's len equals object array's len and all elements are ID's or -1 */
+  return vector;
+}
+
+
+ /* From a script numeric (a drawable ID) set a handle to a drawable.
+  * When ID is -1, sets drawable to NULL and returns no error.
+  * When ID is valid, sets drawable and returns no error.
+  * Otherwise (ID is not -1 and not valid ID of a drawable) returns error.
+  */
+pointer
+get_drawable_from_script (scheme        *sc,
+                          pointer        a,
+                          gint           id,
+                          PikaDrawable **drawable_handle)
+{
+  if (id == -1)
+    {
+      /* -1 is scriptfu language for NULL i.e. none for an optional */
+      *drawable_handle = NULL;
+    }
+  else
+    {
+      *drawable_handle = pika_drawable_get_by_id (id);
+      if (! *drawable_handle)
+          return script_error (sc, "Invalid drawable ID", a);
+    }
+
+  /* ensure *drawable_handle is NULL or a valid reference to a drawable */
+  return NULL;  /* no error */
+}

plug-ins/script-fu/libscriptfu/scheme-marshal.h

@@ -0,0 +1,49 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCHEME_MARSHAL_H__
+#define __SCHEME_MARSHAL_H__
+
+pointer       get_drawable_from_script         (scheme        *sc,
+                                                pointer        a,
+                                                gint           id,
+                                                PikaDrawable **drawable_handle);
+
+pointer       marshal_ID_to_drawable           (scheme   *sc,
+                                                pointer   a,
+                                                gint      id,
+                                                GValue   *value);
+
+pointer       marshal_vector_to_drawable_array (scheme   *sc,
+                                                pointer   a,
+                                                GValue   *value);
+
+void          marshal_path_string_to_gfile     (scheme   *sc,
+                                                pointer   a,
+                                                GValue   *value);
+
+
+pointer       marshal_returned_object_array_to_vector (scheme   *sc,
+                                                       GValue   *value);
+
+gchar *       marshal_returned_gfile_to_string        (GValue   *value);
+
+#endif /* __SCHEME_MARSHAL_H__ */

plug-ins/script-fu/libscriptfu/scheme-wrapper.h

@@ -0,0 +1,57 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCHEME_WRAPPER_H__
+#define __SCHEME_WRAPPER_H__
+
+#include "tinyscheme/scheme.h"
+
+typedef void (*TsCallbackFunc) (void);
+typedef pointer (*TsWrapperFunc) (scheme*, pointer);
+
+
+void          tinyscheme_init         (GList        *path,
+                                       gboolean      register_scripts);
+
+void          ts_set_run_mode         (PikaRunMode   run_mode);
+
+void          ts_set_print_flag       (gint          print_flag);
+void          ts_print_welcome        (void);
+
+const gchar * ts_get_success_msg      (void);
+
+void          ts_interpret_stdin      (void);
+
+/* if the return value is 0, success. error otherwise. */
+gint          ts_interpret_string     (const gchar  *expr);
+
+void          ts_stdout_output_func   (TsOutputType  type,
+                                       const char   *string,
+                                       int           len,
+                                       gpointer      user_data);
+void          ts_gstring_output_func  (TsOutputType  type,
+                                       const char   *string,
+                                       int           len,
+                                       gpointer      user_data);
+void          ts_register_quit_callback         (TsCallbackFunc callback);
+void          ts_register_post_command_callback (TsCallbackFunc callback);
+
+#endif /* __SCHEME_WRAPPER_H__ */

plug-ins/script-fu/libscriptfu/script-fu-arg.c

@@ -0,0 +1,920 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <string.h>
+
+#include <libpika/pika.h>
+
+#include "script-fu-types.h"
+#include "script-fu-arg.h"
+#include "script-fu-utils.h"
+
+
+/*
+ * Methods of SFArg.
+ * SFArg is an informal class.
+ * All methods take first argument SFArg*, i.e. self.
+ *
+ * A SFArg is similar to a GValue and a GParamSpec.
+ * Like a GValue, it holds a value.
+ * Like a GParamSpec, it is metadata and holds a default value.
+ *
+ * In PIKA 2, extension-script-fu stays running and keeps instances of SFArg in memory.
+ * This is how ScriptFu "settings" aka "last values" are persistent for a session of PIKA.
+ *
+ * In PIKA 2, in the GUI implemented by ScriptFu (script-fu-interface.c),
+ * initial values of widgets are taken from SFArg (s),
+ * and result values of widgets are written back to SFArg.
+ *
+ * In PIKA 3, SFArg might be somewhat replaced with PikaConfig.
+ * Then many of these methods are not needed.
+ *
+ * Roughly, the methods hide how to convert/represent SFArgs back/forth
+ * to [GParamSpec, GValue, Scheme string representation.]
+ *
+ * Since SFArg is a union, similar to a GValue, the code is mostly switch on type.
+ */
+
+/*
+ * An SFArg has a type SFArgType that denotes not only a type, but a kind of widget.
+ * For example, SF_STRING denotes string type and a string entry widget,
+ * while SF_TEXT denotes a string type and a multiline text editing widget.
+ *
+ * But the SFArgType:SF_ADJUSTMENT further specifies a kind of widget,
+ * either spinner or slider.
+ * I.E. SFArgType is not one-to-one with widget kind.
+ *
+ * Unlike PythonFu, there is no SFArgType.SF_INT.
+ * Thus a ScriptFu author cannot specify an int-valued widget.
+ * While Scheme speakers understand Scheme uses "numeric" for both float and int,
+ * this might be confusing to script authors using other programming languages.
+ *
+ * SF_VALUE probably should be obsoleted.
+ * Search ChangeLog for mention of "SF_VALUE"
+ * See below, the only difference is that one get string escaped.
+ * Otherwise, SF_VALUE is identical to SF_STRING.
+ * Probably SF_VALUE still exists just for backward compatibility.
+ *
+ * SFArgType denotes not only a C type, but also a Scheme type.
+ * For example, SF_ADJUSTMENT denotes the C type "float"
+ * and the Scheme type "numeric" (which encompasses float and int.)
+ * Another example, SF_PATTERN denotes the C type PikaPattern
+ * and the Scheme type string (names of brushes are used in scripts.)
+ */
+
+
+static void pspec_set_default_file (GParamSpec *pspec, const gchar *filepath);
+static void append_int_repr_from_gvalue (GString *result_string, GValue *gvalue);
+
+/* Free any allocated members.
+ * Somewhat hides what members of the SFArg struct are allocated.
+ * !!! A few other places in the code do the allocations.
+ * !!! A few other places in the code free members.
+ */
+void
+script_fu_arg_free (SFArg *arg)
+{
+  g_free (arg->label);
+
+  switch (arg->type)
+    {
+    case SF_IMAGE:
+    case SF_DRAWABLE:
+    case SF_LAYER:
+    case SF_CHANNEL:
+    case SF_VECTORS:
+    case SF_DISPLAY:
+    case SF_COLOR:
+    case SF_TOGGLE:
+      break;
+
+    case SF_VALUE:
+    case SF_STRING:
+    case SF_TEXT:
+      g_free (arg->default_value.sfa_value);
+      g_free (arg->value.sfa_value);
+      break;
+
+    case SF_ADJUSTMENT:
+      break;
+
+    case SF_FILENAME:
+    case SF_DIRNAME:
+      g_free (arg->default_value.sfa_file.filename);
+      g_free (arg->value.sfa_file.filename);
+      break;
+
+    /* FUTURE: font..gradient could all use the same code.
+     * Since the type in the union are all the same: gchar*.
+     * That is, group these cases with SF_VALUE.
+     * But this method should go away altogether.
+     */
+    case SF_FONT:
+      g_free (arg->default_value.sfa_font);
+      g_free (arg->value.sfa_font);
+      break;
+
+    case SF_PALETTE:
+      g_free (arg->default_value.sfa_palette);
+      g_free (arg->value.sfa_palette);
+      break;
+
+    case SF_PATTERN:
+      g_free (arg->default_value.sfa_pattern);
+      g_free (arg->value.sfa_pattern);
+      break;
+
+    case SF_GRADIENT:
+      g_free (arg->default_value.sfa_gradient);
+      g_free (arg->value.sfa_gradient);
+      break;
+
+    case SF_BRUSH:
+      g_free (arg->default_value.sfa_brush);
+      g_free (arg->value.sfa_brush);
+      break;
+
+    case SF_OPTION:
+      g_slist_free_full (arg->default_value.sfa_option.list,
+                         (GDestroyNotify) g_free);
+      break;
+
+    case SF_ENUM:
+      g_free (arg->default_value.sfa_enum.type_name);
+      break;
+    }
+}
+
+/* Reset: copy the default value to current value. */
+void
+script_fu_arg_reset (SFArg *arg, gboolean should_reset_ids)
+{
+  SFArgValue *value         = &arg->value;
+  SFArgValue *default_value = &arg->default_value;
+
+  switch (arg->type)
+    {
+    case SF_IMAGE:
+    case SF_DRAWABLE:
+    case SF_LAYER:
+    case SF_CHANNEL:
+    case SF_VECTORS:
+    case SF_DISPLAY:
+      if (should_reset_ids)
+        {
+          /* !!! Use field name "sfa_image"; all these cases have same type in union.
+           * The field type is an int, this is an ID.
+           * We can use the same trick to group other cases, below.
+           */
+          value->sfa_image = default_value->sfa_image;
+        }
+
+      break;
+
+    case SF_COLOR:
+      value->sfa_color = default_value->sfa_color;
+      break;
+
+    case SF_TOGGLE:
+      value->sfa_toggle = default_value->sfa_toggle;
+      break;
+
+    case SF_VALUE:
+    case SF_STRING:
+    case SF_TEXT:
+      g_free (value->sfa_value);
+      value->sfa_value = g_strdup (default_value->sfa_value);
+      break;
+
+    case SF_ADJUSTMENT:
+      value->sfa_adjustment.value = default_value->sfa_adjustment.value;
+      break;
+
+    case SF_FILENAME:
+    case SF_DIRNAME:
+      g_free (value->sfa_file.filename);
+      value->sfa_file.filename = g_strdup (default_value->sfa_file.filename);
+      break;
+
+    /* FUTURE: font..gradient could all use the same code.
+     * Since the type in the union are all the same: gchar*.
+     * That is, group these cases with SF_VALUE.
+     */
+    case SF_FONT:
+      g_free (value->sfa_font);
+      value->sfa_font = g_strdup (default_value->sfa_font);
+      break;
+
+    case SF_PALETTE:
+      g_free (value->sfa_palette);
+      value->sfa_palette = g_strdup (default_value->sfa_palette);
+      break;
+
+    case SF_PATTERN:
+      g_free (value->sfa_pattern);
+      value->sfa_pattern = g_strdup (default_value->sfa_pattern);
+      break;
+
+    case SF_GRADIENT:
+      g_free (value->sfa_gradient);
+      value->sfa_gradient = g_strdup (default_value->sfa_gradient);
+      break;
+
+    case SF_BRUSH:
+      g_free (value->sfa_brush);
+      value->sfa_brush = g_strdup (default_value->sfa_brush);
+      break;
+
+    case SF_OPTION:
+      value->sfa_option.history = default_value->sfa_option.history;
+      break;
+
+    case SF_ENUM:
+      value->sfa_enum.history = default_value->sfa_enum.history;
+      break;
+    }
+}
+
+/* Return param spec that describes the arg.
+ * Convert instance of SFArg to instance of GParamSpec.
+ *
+ * Used to specify an arg to the PDB proc which this script implements.
+ * The GParamSpec is "floating" meaning ownership will transfer
+ * to the PikaPDBProcedure.
+ *
+ * Ensure GParamSpec has a default except as noted below.
+ * Default value from self.
+ *
+ * FUTURE: use PikaProcedureDialog
+ * Because PikaProcedureDialog creates widgets from properties/paramspecs,
+ * this should convey what SFArg denotes about desired widget kind,
+ * but it doesn't fully do that yet.
+ */
+GParamSpec *
+script_fu_arg_get_param_spec (SFArg       *arg,
+                              const gchar *name,
+                              const gchar *nick)
+{
+  GParamSpec * pspec = NULL;
+
+  switch (arg->type)
+    {
+      /* No defaults for PIKA objects: Image, Item subclasses, Display */
+    case SF_IMAGE:
+      pspec = pika_param_spec_image (name,
+                                     nick,
+                                     arg->label,
+                                     TRUE,  /* None is valid. */
+                                     G_PARAM_READWRITE);
+      break;
+
+    case SF_DRAWABLE:
+      pspec = pika_param_spec_drawable (name,
+                                        nick,
+                                        arg->label,
+                                        TRUE,
+                                        G_PARAM_READWRITE);
+      break;
+
+    case SF_LAYER:
+      pspec = pika_param_spec_layer (name,
+                                     nick,
+                                     arg->label,
+                                     TRUE,
+                                     G_PARAM_READWRITE);
+      break;
+
+    case SF_CHANNEL:
+      pspec = pika_param_spec_channel (name,
+                                       nick,
+                                       arg->label,
+                                       TRUE,
+                                       G_PARAM_READWRITE);
+      break;
+
+    case SF_VECTORS:
+      pspec = pika_param_spec_vectors (name,
+                                       nick,
+                                       arg->label,
+                                       TRUE,
+                                       G_PARAM_READWRITE);
+      break;
+
+    case SF_DISPLAY:
+      pspec = pika_param_spec_display (name,
+                                       nick,
+                                       arg->label,
+                                       TRUE,
+                                       G_PARAM_READWRITE);
+      break;
+
+    case SF_COLOR:
+      /* Pass address of default color i.e. instance of PikaRGB.
+       * Color is owned by ScriptFu and exists for lifetime of SF process.
+       */
+      pspec = pika_param_spec_rgb (name,
+                                   nick,
+                                   arg->label,
+                                   TRUE,  /* is alpha relevant */
+                                   &arg->default_value.sfa_color,
+                                   G_PARAM_READWRITE);
+      /* FUTURE: Default not now appear in PDB browser, but appears in widgets? */
+      break;
+
+    case SF_TOGGLE:
+      /* Implicit conversion from gint32 to gboolean. */
+      pspec = g_param_spec_boolean (name,
+                                    nick,
+                                    arg->label,
+                                    arg->default_value.sfa_toggle,
+                                    G_PARAM_READWRITE);
+      break;
+
+    /* FUTURE special widgets for multiline text.
+     * script-fu-interface does, but PikaProcedureDialog does not.
+     */
+    case SF_VALUE:
+    case SF_STRING:
+    case SF_TEXT:
+      pspec = g_param_spec_string (name,
+                                   nick,
+                                   arg->label,
+                                   arg->default_value.sfa_value,
+                                   G_PARAM_READWRITE);
+      break;
+
+    /* Subclasses of PikaResource.  Special widgets. */
+    case SF_FONT:
+      pspec = pika_param_spec_font (name,
+                                    nick,
+                                    arg->label,
+                                    FALSE,  /* none OK */
+                                    G_PARAM_READWRITE | PIKA_PARAM_NO_VALIDATE);
+      break;
+    case SF_PALETTE:
+      pspec = pika_param_spec_palette (name,
+                                       nick,
+                                       arg->label,
+                                       FALSE,  /* none OK */
+                                       G_PARAM_READWRITE | PIKA_PARAM_NO_VALIDATE);
+      break;
+
+    case SF_PATTERN:
+      pspec = pika_param_spec_pattern (name,
+                                       nick,
+                                       arg->label,
+                                       FALSE,  /* none OK */
+                                       G_PARAM_READWRITE | PIKA_PARAM_NO_VALIDATE);
+      break;
+
+    case SF_GRADIENT:
+      pspec = pika_param_spec_gradient (name,
+                                        nick,
+                                        arg->label,
+                                        FALSE,  /* none OK */
+                                        G_PARAM_READWRITE | PIKA_PARAM_NO_VALIDATE);
+      break;
+
+    case SF_BRUSH:
+      pspec = pika_param_spec_brush (name,
+                                     nick,
+                                     arg->label,
+                                     FALSE,  /* none OK */
+                                     G_PARAM_READWRITE | PIKA_PARAM_NO_VALIDATE);
+      break;
+
+    case SF_ADJUSTMENT:
+      /* switch on number of decimal places aka "digits
+       * !!! on the default value, not the current value.
+       * Decimal places == 0 means type integer, else float
+       */
+      if (arg->default_value.sfa_adjustment.digits == 0)
+        pspec = g_param_spec_int (name, nick, arg->label,
+                                  arg->default_value.sfa_adjustment.lower,
+                                  arg->default_value.sfa_adjustment.upper,
+                                  arg->default_value.sfa_adjustment.value,
+                                  G_PARAM_READWRITE);
+      else
+        pspec = g_param_spec_double (name, nick, arg->label,
+                                     arg->default_value.sfa_adjustment.lower,
+                                     arg->default_value.sfa_adjustment.upper,
+                                     arg->default_value.sfa_adjustment.value,
+                                     G_PARAM_READWRITE);
+      break;
+
+    case SF_FILENAME:
+    case SF_DIRNAME:
+      pspec = g_param_spec_object (name,
+                                   nick,
+                                   arg->label,
+                                   G_TYPE_FILE,
+                                   G_PARAM_READWRITE |
+                                   PIKA_PARAM_NO_VALIDATE);
+      pspec_set_default_file (pspec, arg->default_value.sfa_file.filename);
+      /* FUTURE: Default not now appear in PDB browser, but appears in widgets? */
+      break;
+
+    case SF_ENUM:
+      /* history is the last used value AND the default. */
+      pspec = g_param_spec_enum (name,
+                                 nick,
+                                 arg->label,
+                                 g_type_from_name (arg->default_value.sfa_enum.type_name),
+                                 arg->default_value.sfa_enum.history,
+                                 G_PARAM_READWRITE);
+      break;
+
+    case SF_OPTION:
+      pspec = g_param_spec_int (name,
+                                nick,
+                                arg->label,
+                                0,        /* Always zero based. */
+                                g_slist_length (arg->default_value.sfa_option.list),
+                                arg->default_value.sfa_option.history,
+                                G_PARAM_READWRITE);
+      /* FUTURE: Model values not now appear in PDB browser NOR in widgets? */
+      /* FUTURE: Does not show a combo box widget ??? */
+      break;
+    }
+
+  return pspec;
+}
+
+
+/* Append a Scheme representation of the arg value from the given gvalue.
+ * Append to a Scheme text to be interpreted.
+ *
+ * The SFArg only specifies the type,
+ * but the GType held by the GValue must be the same or convertable.
+ *
+ * The repr comes from the value of the GValue, not the value of the SFArg.
+ *
+ * Used when PIKA is calling the PDB procedure implemented by the script,
+ * passing a GValueArray.
+ */
+void
+script_fu_arg_append_repr_from_gvalue (SFArg       *arg,
+                                       GString     *result_string,
+                                       GValue      *gvalue)
+{
+  g_debug ("script_fu_arg_append_repr_from_gvalue %s", arg->label);
+  switch (arg->type)
+    {
+    case SF_IMAGE:
+    case SF_DRAWABLE:
+    case SF_LAYER:
+    case SF_CHANNEL:
+    case SF_VECTORS:
+    case SF_DISPLAY:
+      {
+        GObject *object = g_value_get_object (gvalue);
+        gint     id     = -1;
+
+        if (object)
+          g_object_get (object, "id", &id, NULL);
+
+        g_string_append_printf (result_string, "%d", id);
+      }
+      break;
+
+    case SF_COLOR:
+      {
+        PikaRGB color;
+        guchar  r, g, b;
+
+        pika_value_get_rgb (gvalue, &color);
+        pika_rgb_get_uchar (&color, &r, &g, &b);
+        g_string_append_printf (result_string, "'(%d %d %d)",
+                                (gint) r, (gint) g, (gint) b);
+      }
+      break;
+
+    case SF_TOGGLE:
+      g_string_append_printf (result_string, (g_value_get_boolean (gvalue) ?
+                                  "TRUE" : "FALSE"));
+      break;
+
+    case SF_VALUE:
+      g_string_append (result_string, g_value_get_string (gvalue));
+      break;
+
+    case SF_STRING:
+    case SF_TEXT:
+      {
+        gchar *tmp;
+
+        tmp = script_fu_strescape (g_value_get_string (gvalue));
+        g_string_append_printf (result_string, "\"%s\"", tmp);
+        g_free (tmp);
+      }
+      break;
+
+    case SF_FILENAME:
+    case SF_DIRNAME:
+      {
+        if (G_VALUE_HOLDS_OBJECT (gvalue) && G_VALUE_TYPE (gvalue) == G_TYPE_FILE)
+          {
+            GFile *file = g_value_get_object (gvalue);
+
+            /* Catch: GValue initialized to hold a GFile, but not hold one.
+             * Specificially, PikaProcedureDialog can yield that condition;
+             * the dialog shows "(None)" meaning user has not chosen a file yet.
+             */
+            if (G_IS_FILE (file))
+              {
+                /* Not checking file exists, only creating a descriptive string.
+                 * I.E. not g_file_get_path, which can return NULL.
+                 */
+                gchar *filepath = g_file_get_parse_name (file);
+                /* assert filepath not null. */
+                /* Not escape special chars for whitespace or double quote. */
+                g_string_append_printf (result_string, "\"%s\"", filepath);
+                g_free (filepath);
+              }
+            else
+              {
+                gchar *msg = "Invalid GFile in gvalue.";
+                g_warning ("%s", msg);
+                g_string_append_printf (result_string, "\"%s\"", msg);
+              }
+          }
+        else
+          {
+            gchar *msg = "Expecting GFile in gvalue.";
+            g_warning ("%s", msg);
+            g_string_append_printf (result_string, "\"%s\"", msg);
+          }
+        /* Ensure appended a filepath string OR an error string.*/
+      }
+      break;
+
+    case SF_ADJUSTMENT:
+      {
+        if (arg->default_value.sfa_adjustment.digits != 0)
+          {
+            gchar buffer[G_ASCII_DTOSTR_BUF_SIZE];
+
+            g_ascii_dtostr (buffer, sizeof (buffer), g_value_get_double (gvalue));
+            g_string_append (result_string, buffer);
+          }
+        else
+          {
+            append_int_repr_from_gvalue (result_string, gvalue);
+          }
+      }
+      break;
+
+    case SF_FONT:
+    case SF_PALETTE:
+    case SF_PATTERN:
+    case SF_GRADIENT:
+    case SF_BRUSH:
+      {
+        /* The GValue is a GObject of type inheriting PikaResource */
+        PikaResource *resource;
+        gchar        *name = NULL;
+
+        resource = g_value_get_object (gvalue);
+
+        if (resource)
+          name = pika_resource_get_name (resource);
+
+        g_string_append_printf (result_string, "\"%s\"", name);
+      }
+      break;
+
+    case SF_OPTION:
+      append_int_repr_from_gvalue (result_string, gvalue);
+      break;
+
+    case SF_ENUM:
+      if (G_VALUE_HOLDS_ENUM (gvalue))
+        {
+          /* Effectively upcasting to a less restrictive Scheme class Integer. */
+          g_string_append_printf (result_string, "%d", g_value_get_enum (gvalue));
+        }
+      else
+        {
+          /* For now, occurs when PikaConfig or PikaProcedureDialog does not support GParamEnum. */
+          g_warning ("Expecting GValue holding a GEnum.");
+          /* Append arbitrary int, so no errors in signature of Scheme call.
+           * The call might not yield result the user intended.
+           */
+          g_string_append (result_string, "1");
+        }
+      break;
+    }
+}
+
+/* Append a Scheme representation of the arg value from self's value.
+ * Append to a Scheme text to be interpreted.
+ *
+ * Used when the PDB procedure implemented by the script is being calling interactively,
+ * after a GUI dialog has written user's choices into self's value.
+ *
+ * This method is slated for deletion when script-fu-interface.c is deleted.
+ */
+void
+script_fu_arg_append_repr_from_self (SFArg       *arg,
+                                     GString     *result_string)
+{
+  SFArgValue *arg_value = &arg->value;
+
+  switch (arg->type)
+    {
+    case SF_IMAGE:
+    case SF_DRAWABLE:
+    case SF_LAYER:
+    case SF_CHANNEL:
+    case SF_VECTORS:
+    case SF_DISPLAY:
+      g_string_append_printf (result_string, "%d", arg_value->sfa_image);
+      break;
+
+    case SF_COLOR:
+      {
+        guchar r, g, b;
+
+        pika_rgb_get_uchar (&arg_value->sfa_color, &r, &g, &b);
+        g_string_append_printf (result_string, "'(%d %d %d)",
+                                (gint) r, (gint) g, (gint) b);
+      }
+      break;
+
+    case SF_TOGGLE:
+      g_string_append (result_string, arg_value->sfa_toggle ? "TRUE" : "FALSE");
+      break;
+
+    case SF_VALUE:
+      g_string_append (result_string, arg_value->sfa_value);
+      break;
+
+    case SF_STRING:
+    case SF_TEXT:
+      {
+        gchar *tmp;
+
+        tmp = script_fu_strescape (arg_value->sfa_value);
+        g_string_append_printf (result_string, "\"%s\"", tmp);
+        g_free (tmp);
+      }
+      break;
+
+    case SF_ADJUSTMENT:
+      {
+        gchar buffer[G_ASCII_DTOSTR_BUF_SIZE];
+
+        g_ascii_dtostr (buffer, sizeof (buffer),
+                        arg_value->sfa_adjustment.value);
+        g_string_append (result_string, buffer);
+      }
+      break;
+
+    case SF_FILENAME:
+    case SF_DIRNAME:
+      {
+        gchar *tmp;
+
+        tmp = script_fu_strescape (arg_value->sfa_file.filename);
+        g_string_append_printf (result_string, "\"%s\"", tmp);
+        g_free (tmp);
+      }
+      break;
+
+    case SF_FONT:
+      g_string_append_printf (result_string, "\"%s\"", arg_value->sfa_font);
+      break;
+
+    case SF_PALETTE:
+      g_string_append_printf (result_string, "\"%s\"", arg_value->sfa_palette);
+      break;
+
+    case SF_PATTERN:
+      g_string_append_printf (result_string, "\"%s\"", arg_value->sfa_pattern);
+      break;
+
+    case SF_GRADIENT:
+      g_string_append_printf (result_string, "\"%s\"", arg_value->sfa_gradient);
+      break;
+
+    case SF_BRUSH:
+      g_string_append_printf (result_string, "\"%s\"", arg_value->sfa_brush);
+      break;
+
+    case SF_OPTION:
+      g_string_append_printf (result_string, "%d", arg_value->sfa_option.history);
+      break;
+
+    case SF_ENUM:
+      g_string_append_printf (result_string, "%d", arg_value->sfa_enum.history);
+      break;
+    }
+}
+
+
+/* Array the size of the enum
+ * Counts names generated per SF type per generator session.
+ */
+static gint arg_count[SF_DISPLAY + 1] = { 0, };
+
+void
+script_fu_arg_reset_name_generator (void)
+{
+  for (guint i = 0; i <= SF_DISPLAY; i++)
+    arg_count[i] = 0;
+}
+
+/*
+ * Return a unique name, and non-unique nick, for self.
+ *
+ * Self's label came from a call to script-fu-register ()
+ * and was not lexically checked so is unsuitable for a property name.
+ * ScriptFu does not require script author to provide a unique name
+ * for args in a call to script-fu-register.
+ *
+ * This is a generator.
+ * Returned name is a canonical name for a GParamSpec, i.e. a property name.
+ * It meets the lexical requirements for a property name.
+ * It is unique among all names returned between resets of the generator.
+ * Thus name meets uniquity for names of properties of one object.
+ *
+ * !!! PikaImageProcedures already have properties for convenience arguments,
+ * e.g. a property named "image" "n_drawables" and "drawables"
+ * So we avoid that name clash by starting with "otherImage"
+ *
+ * The name means nothing to human readers of the spec.
+ * Instead, the nick is descriptive for human readers.
+ *
+ * The returned string is owned by the generator, a constant.
+ * The caller need not copy it,
+ * but usually does by creating a GParamSpec.
+ */
+void
+script_fu_arg_generate_name_and_nick (SFArg        *arg,
+                                      const gchar **returned_name,
+                                      const gchar **returned_nick)
+{
+  static gchar  numbered_name[64];
+  gchar        *name = NULL;
+
+  switch (arg->type)
+    {
+    case SF_IMAGE:
+      name = "otherImage";  /* !!! Avoid name clash. */
+      break;
+
+    case SF_DRAWABLE:
+      name = "drawable";
+      break;
+
+    case SF_LAYER:
+      name = "layer";
+      break;
+
+    case SF_CHANNEL:
+      name = "channel";
+      break;
+
+    case SF_VECTORS:
+      name = "vectors";
+      break;
+
+    case SF_DISPLAY:
+      name = "display";
+      break;
+
+    case SF_COLOR:
+      name = "color";
+      break;
+
+    case SF_TOGGLE:
+      name = "toggle";
+      break;
+
+    case SF_VALUE:
+      name = "value";
+      break;
+
+    case SF_STRING:
+      name = "string";
+      break;
+
+    case SF_TEXT:
+      name = "text";
+      break;
+
+    case SF_ADJUSTMENT:
+      name = "adjustment";
+      break;
+
+    case SF_FILENAME:
+      name = "filename";
+      break;
+
+    case SF_DIRNAME:
+      name = "dirname";
+      break;
+
+    case SF_FONT:
+      name = "font";
+      break;
+
+    case SF_PALETTE:
+      name = "palette";
+      break;
+
+    case SF_PATTERN:
+      name = "pattern";
+      break;
+
+    case SF_BRUSH:
+      name = "brush";
+      break;
+
+    case SF_GRADIENT:
+      name = "gradient";
+      break;
+
+    case SF_OPTION:
+      name = "option";
+      break;
+
+    case SF_ENUM:
+      name = "enum";
+      break;
+    }
+
+  if (arg_count[arg->type] == 0)
+    {
+      g_strlcpy (numbered_name, name, sizeof (numbered_name));
+    }
+  else
+    {
+      g_snprintf (numbered_name, sizeof (numbered_name),
+                  "%s-%d", name, arg_count[arg->type] + 1);
+    }
+
+  arg_count[arg->type]++;
+
+  *returned_name = numbered_name;
+
+  /* nick is what the script author said describes the arg */
+  *returned_nick = arg->label;
+}
+
+
+/* Set the default of a GParamSpec to a GFile for a path string.
+ * The GFile is allocated and ownership is transferred to the GParamSpec.
+ * The GFile is only a name and a so-named file might not exist.
+ */
+static void
+pspec_set_default_file (GParamSpec *pspec, const gchar *filepath)
+{
+  GValue  gvalue = G_VALUE_INIT;
+  GFile  *gfile  = NULL;
+
+  g_value_init (&gvalue, G_TYPE_FILE);
+  gfile = g_file_new_for_path (filepath);
+  g_value_set_object (&gvalue, gfile);
+  g_param_value_set_default (pspec, &gvalue);
+}
+
+/* Append a string repr of an integer valued gvalue to given GString.
+ * When the gvalue doesn't hold an integer, warn and append arbitrary int literal.
+ */
+static void
+append_int_repr_from_gvalue (GString *result_string, GValue *gvalue)
+{
+  if (G_VALUE_HOLDS_INT (gvalue))
+    {
+      g_string_append_printf (result_string, "%d", g_value_get_int (gvalue));
+    }
+  else
+    {
+      g_warning ("Expecting GValue holding an int.");
+      /* Append arbitrary int, so no errors in signature of Scheme call.
+       * The call might not yield result the user intended.
+       */
+      g_string_append (result_string, "1");
+    }
+}

plug-ins/script-fu/libscriptfu/script-fu-arg.h

@@ -0,0 +1,43 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_ARG_H__
+#define __SCRIPT_FU_ARG_H__
+
+void        script_fu_arg_free                    (SFArg    *arg);
+void        script_fu_arg_reset                   (SFArg    *arg,
+                                                   gboolean should_reset_ids);
+
+GParamSpec *script_fu_arg_get_param_spec          (SFArg       *arg,
+                                                   const gchar *name,
+                                                   const gchar *nick);
+void        script_fu_arg_append_repr_from_gvalue (SFArg       *arg,
+                                                   GString     *result_string,
+                                                   GValue      *gvalue);
+void        script_fu_arg_append_repr_from_self   (SFArg       *arg,
+                                                   GString     *result_string);
+
+void        script_fu_arg_reset_name_generator    (void);
+void        script_fu_arg_generate_name_and_nick  (SFArg        *arg,
+                                                   const gchar **name,
+                                                   const gchar **nick);
+
+#endif /*  __SCRIPT_FU_ARG__  */

plug-ins/script-fu/libscriptfu/script-fu-command.c

@@ -0,0 +1,154 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <libpika/pika.h>
+
+#include "script-fu-types.h"    /* SFScript */
+#include "script-fu-lib.h"
+#include "script-fu-script.h"
+
+#include "script-fu-command.h"
+
+
+/* Methods for interpreting commands.
+ *
+ * Usually there is a stack of calls similar to:
+ *       script_fu_run_image_procedure (outer run func)
+ * calls script_fu_interpret_image_proc
+ * calls script_fu_run_command
+ * calls ts_interpret_string
+ * calls the inner run func in Scheme
+ *
+ * but script_fu_run_command is also called directly for loading scripts.
+ *
+ * FUTURE: see also similar code in script-fu-interface.c
+ * which could be migrated here.
+ */
+
+
+/* Interpret a command.
+ *
+ * When errors during interpretation:
+ * 1) set the error message from tinyscheme into GError at given handle.
+ * 2) return FALSE
+ * otherwise, return TRUE and discard any result of interpretation
+ * ScriptFu return values only have a PikaPDBStatus,
+ * since ScriptFu plugin scripts can only be declared returning void.
+ *
+ * While interpreting, any errors from further calls to the PDB
+ * can show error dialogs in any PIKA gui,
+ * unless the caller has taken responsibility with a prior call to
+ * pika_plug_in_set_pdb_error_handler
+ *
+ * FIXME: see script_fu_run_procedure.
+ * It does not call pika_plug_in_set_pdb_error_handler for NON-INTERACTIVE mode.
+ */
+gboolean
+script_fu_run_command (const gchar  *command,
+                       GError      **error)
+{
+  GString  *output;
+  gboolean  success = FALSE;
+
+  g_debug ("script_fu_run_command: %s", command);
+  output = g_string_new (NULL);
+  script_fu_redirect_output_to_gstr (output);
+
+  if (script_fu_interpret_string (command))
+    {
+      g_set_error (error, PIKA_PLUG_IN_ERROR, 0, "%s", output->str);
+    }
+  else
+    {
+      success = TRUE;
+    }
+
+  g_string_free (output, TRUE);
+
+  return success;
+}
+
+
+
+/* Interpret a script that defines a PikaImageProcedure.
+ *
+ * Similar to v2 code in script-fu-interface.c, except:
+ * 1) builds a command from a GValueArray from a PikaConfig,
+ *    instead of from local array of SFArg.
+ * 2) adds actual args image, drawable, etc. for PikaImageProcedure
+ */
+PikaValueArray *
+script_fu_interpret_image_proc (
+                            PikaProcedure        *procedure,
+                            SFScript             *script,
+                            PikaImage            *image,
+                            guint                 n_drawables,
+                            PikaDrawable        **drawables,
+                            const PikaValueArray *args)
+{
+  gchar          *command;
+  PikaValueArray *result = NULL;
+  gboolean        interpretation_result;
+  GError         *error = NULL;
+
+  command = script_fu_script_get_command_for_image_proc (script, image, n_drawables, drawables, args);
+
+  /* Take responsibility for handling errors from the scripts further calls to PDB.
+   * ScriptFu does not show an error dialog, but forwards errors back to PIKA.
+   * This only tells PIKA that ScriptFu itself will forward PikaPDBStatus errors from
+   * this scripts calls to the PDB.
+   * The onus is on this script's called PDB procedures to return errors in the PikaPDBStatus.
+   * Any that do not, but for example only call pika-message, are breaching contract.
+   */
+  pika_plug_in_set_pdb_error_handler (pika_get_plug_in (),
+                                      PIKA_PDB_ERROR_HANDLER_PLUGIN);
+
+  interpretation_result = script_fu_run_command (command, &error);
+  g_free (command);
+  if (! interpretation_result)
+    {
+      /* This is to the console.
+       * script->name not localized.
+       * error->message expected to be localized.
+       * PIKA will later display "PDB procedure failed: <message>" localized.
+       */
+      g_warning ("While executing %s: %s",
+                 script->name,
+                 error->message);
+      /* A GError was allocated and this will take ownership. */
+      result = pika_procedure_new_return_values (procedure,
+                                                 PIKA_PDB_EXECUTION_ERROR,
+                                                 error);
+    }
+  else
+    {
+      result = pika_procedure_new_return_values (procedure,
+                                                 PIKA_PDB_SUCCESS,
+                                                 NULL);
+    }
+
+  pika_plug_in_set_pdb_error_handler (pika_get_plug_in (),
+                                      PIKA_PDB_ERROR_HANDLER_INTERNAL);
+
+  return result;
+}

plug-ins/script-fu/libscriptfu/script-fu-command.h

@@ -0,0 +1,35 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+ #ifndef __SCRIPT_FU_COMMAND_H__
+ #define __SCRIPT_FU_COMMAND_H__
+
+gboolean        script_fu_run_command          (const gchar  *command,
+                                                GError      **error);
+
+PikaValueArray *script_fu_interpret_image_proc (PikaProcedure        *procedure,
+                                                SFScript             *script,
+                                                PikaImage            *image,
+                                                guint                 n_drawables,
+                                                PikaDrawable        **drawables,
+                                                const PikaValueArray *args);
+
+#endif /* __SCRIPT_FU_COMMAND_H__ */

plug-ins/script-fu/libscriptfu/script-fu-compat.c

@@ -0,0 +1,214 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+#include "tinyscheme/scheme-private.h"
+#include "script-fu-compat.h"
+
+/*
+ * Make some PDB procedure names deprecated in ScriptFu.
+ * Until such time as we turn deprecation off and make them obsolete.
+ *
+ * This only makes them deprecated in ScriptFu.
+ */
+
+
+/* private */
+
+static const struct
+{
+  const gchar *old_name;
+  const gchar *new_name;
+}
+compat_procs[] =
+{
+  /*
+   * deprecations since 2.99
+   *
+   * With respect to ScriptFu,
+   * the old names are *obsolete in the PDB* (as of this writing.)
+   * That is, they don't exist in the PDB with the same signature.
+   * There is no "compatibility" procedure in the PDB.
+   *
+   * With respect to Python using GI, some old names are *NOT* obsolete.
+   * (Where "some" means those dealing with ID.)
+   * I.E. Pika.Image.is_valid() exists but takes a GObject *, not an int ID.
+   *
+   * Original data was constructed more or less by hand, partially automated.
+   */
+   { "pika-brightness-contrast"               , "pika-drawable-brightness-contrast"      },
+   { "pika-brushes-get-brush"                 , "pika-context-get-brush"                 },
+   { "pika-drawable-is-channel"               , "pika-item-id-is-channel"                },
+   { "pika-drawable-is-layer"                 , "pika-item-id-is-layer"                  },
+   { "pika-drawable-is-layer-mask"            , "pika-item-id-is-layer-mask"             },
+   { "pika-drawable-is-text-layer"            , "pika-item-id-is-text-layer"             },
+   { "pika-drawable-is-valid"                 , "pika-item-id-is-valid"                  },
+   { "pika-drawable-transform-2d"             , "pika-item-transform-2d"                 },
+   { "pika-drawable-transform-flip"           , "pika-item-transform-flip"               },
+   { "pika-drawable-transform-flip-simple"    , "pika-item-transform-flip-simple"        },
+   { "pika-drawable-transform-matrix"         , "pika-item-transform-matrix"             },
+   { "pika-drawable-transform-perspective"    , "pika-item-transform-perspective"        },
+   { "pika-drawable-transform-rotate"         , "pika-item-transform-rotate"             },
+   { "pika-drawable-transform-rotate-simple"  , "pika-item-transform-rotate-simple"      },
+   { "pika-drawable-transform-scale"          , "pika-item-transform-scale"              },
+   { "pika-drawable-transform-shear"          , "pika-item-transform-shear"              },
+   { "pika-display-is-valid"                  , "pika-display-id-is-valid"               },
+   { "pika-image-is-valid"                    , "pika-image-id-is-valid"                 },
+   { "pika-item-is-channel"                   , "pika-item-id-is-channel"                },
+   { "pika-item-is-drawable"                  , "pika-item-id-is-drawable"               },
+   { "pika-item-is-layer"                     , "pika-item-id-is-layer"                  },
+   { "pika-item-is-layer-mask"                , "pika-item-id-is-layer-mask"             },
+   { "pika-item-is-selection"                 , "pika-item-id-is-selection"              },
+   { "pika-item-is-text-layer"                , "pika-item-id-is-text-layer"             },
+   { "pika-item-is-valid"                     , "pika-item-id-is-valid"                  },
+   { "pika-item-is-vectors"                   , "pika-item-id-is-vectors"                },
+   { "pika-procedural-db-dump"                , "pika-pdb-dump"                          },
+   { "pika-procedural-db-get-data"            , "pika-pdb-get-data"                      },
+   { "pika-procedural-db-set-data"            , "pika-pdb-set-data"                      },
+   { "pika-procedural-db-get-data-size"       , "pika-pdb-get-data-size"                 },
+   { "pika-procedural-db-proc-arg"            , "pika-pdb-get-proc-argument"             },
+   { "pika-procedural-db-proc-info"           , "pika-pdb-get-proc-info"                 },
+   { "pika-procedural-db-proc-val"            , "pika-pdb-get-proc-return-value"         },
+   { "pika-procedural-db-proc-exists"         , "pika-pdb-proc-exists"                   },
+   { "pika-procedural-db-query"               , "pika-pdb-query"                         },
+   { "pika-procedural-db-temp-name"           , "pika-pdb-temp-name"                     },
+   { "pika-image-get-exported-uri"            , "pika-image-get-exported-file"           },
+   { "pika-image-get-imported-uri"            , "pika-image-get-imported-file"           },
+   { "pika-image-get-xcf-uri"                 , "pika-image-get-xcf-file"                },
+   { "pika-image-get-filename"                , "pika-image-get-file"                    },
+   { "pika-image-set-filename"                , "pika-image-set-file"                    },
+   { "pika-plugin-menu-register"              , "pika-pdb-add-proc-menu-path"            },
+   { "pika-plugin-get-pdb-error-handler"      , "pika-plug-in-get-pdb-error-handler"     },
+   { "pika-plugin-help-register"              , "pika-plug-in-help-register"             },
+   { "pika-plugin-menu-branch-register"       , "pika-plug-in-menu-branch-register"      },
+   { "pika-plugin-set-pdb-error-handler"      , "pika-plug-in-set-pdb-error-handler"     },
+   { "pika-plugins-query"                     , "pika-plug-ins-query"                    },
+   { "file-gtm-save"                          , "file-html-table-save"                   },
+   { "python-fu-histogram-export"             , "histogram-export"                       },
+   { "python-fu-gradient-save-as-css"         , "gradient-save-as-css"                   }
+};
+
+static gchar *empty_string = "";
+
+
+static void
+define_deprecated_scheme_func (const char   *old_name,
+                               const char   *new_name,
+                               const scheme *sc)
+{
+  gchar *buff;
+
+  /* Creates a definition in Scheme of a function that calls a PDB procedure.
+   *
+   * The magic below that makes it deprecated:
+   * - the "--pika-proc-db-call"
+   * - defining under the old_name but calling the new_name
+
+   * See scheme-wrapper.c, where this was copied from.
+   * But here creates scheme definition of old_name
+   * that calls a PDB procedure of a different name, new_name.
+   *
+   * As functional programming is: eval(define(apply f)).
+   * load_string is more typically called eval().
+   */
+  buff = g_strdup_printf (" (define (%s . args)"
+                          " (apply --pika-proc-db-call \"%s\" args))",
+                          old_name, new_name);
+
+  sc->vptr->load_string ((scheme *) sc, buff);
+
+  g_free (buff);
+}
+
+
+/*  public functions  */
+
+/* Define Scheme functions whose name is old name
+ * that call compatible PDB procedures whose name is new name.
+ * Define into the lisp machine.
+
+ * Compatible means: signature same, semantics same.
+ * The new names are not "compatibility" procedures, they are the new procedures.
+ *
+ * This can overwrite existing definitions in the lisp machine.
+ * If the PDB has the old name already
+ * (if a compatibility procedure is defined in the PDB
+ * or the old name exists with a different signature)
+ * and ScriptFu already defined functions for procedures of the PDB,
+ * this will overwrite the ScriptFu definition,
+ * but produce the same overall effect.
+ * The definition here will not call the old name PDB procedure,
+ * but from ScriptFu call the new name PDB procedure.
+ */
+void
+define_compat_procs (scheme *sc)
+{
+  gint i;
+
+  for (i = 0; i < G_N_ELEMENTS (compat_procs); i++)
+    {
+      define_deprecated_scheme_func (compat_procs[i].old_name,
+                                     compat_procs[i].new_name,
+                                     sc);
+    }
+}
+
+/* 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++)
+    {
+      if (strcmp (compat_procs[i].new_name, new_name) == 0)
+        {
+          result = compat_procs[i].old_name;
+          break;
+        }
+    }
+  return result;
+
+}
+
+/* Not used.
+ * Keep for future implementation: catch "undefined symbol" from lisp machine.
+ */
+gboolean
+is_deprecated (const char *old_name)
+{
+  gint i;
+  gboolean result = FALSE;
+
+  /* search keys of dictionary/map. */
+  for (i = 0; i < G_N_ELEMENTS (compat_procs); i++)
+  {
+    if (strcmp (compat_procs[i].old_name, old_name) == 0)
+      {
+        result = TRUE;
+        break;
+      }
+  }
+  return result;
+}

plug-ins/script-fu/libscriptfu/script-fu-compat.h

@@ -0,0 +1,31 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_COMPAT_H__
+#define __SCRIPT_FU_COMPAT_H__
+
+
+void          define_compat_procs (scheme *sc);
+gboolean      is_deprecated       (const char *old_name);
+const gchar * deprecated_name_for (const char *new_name);
+
+
+#endif /*  __SCRIPT_FU_COMPAT_H__  */

plug-ins/script-fu/libscriptfu/script-fu-dialog.c

@@ -0,0 +1,256 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * Copyright (C) 1995 Spencer Kimball and Peter Mattis
+ *
+ * script-fu-dialog.c
+ * Copyright (C) 2022 Lloyd Konneker
+ *
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <libpika/pikaui.h>
+
+#include "script-fu-types.h"    /* SFScript */
+#include "script-fu-script.h"   /* get_title */
+#include "script-fu-command.h"
+
+#include "script-fu-dialog.h"
+
+
+/* An informal class that shows a dialog for a script then runs the script.
+ * It is internal to libscriptfu.
+ *
+ * The dialog is modal for the script:
+ * OK button hides the dialog then runs the script once.
+ *
+ * The dialog is non-modal with respect to the PIKA app GUI, which remains responsive.
+ *
+ * When called from plugin extension-script-fu, the dialog is modal on the extension:
+ * although PIKA app continues responsive, a user choosing a menu item
+ * that is also implemented by a script and extension-script-fu
+ * will not show a dialog until the first called script finishes.
+ */
+
+/* FUTURE: delete this after v3 is stable. */
+#define DEBUG_CONFIG_PROPERTIES  TRUE
+
+#if DEBUG_CONFIG_PROPERTIES
+static void
+dump_properties (PikaProcedureConfig *config)
+{
+  GParamSpec **pspecs;
+  guint        n_pspecs;
+
+  pspecs = g_object_class_list_properties (G_OBJECT_GET_CLASS (config),
+                                           &n_pspecs);
+  for (guint i = 1; i < n_pspecs; i++)
+    g_printerr ("%s %s\n", pspecs[i]->name, G_PARAM_SPEC_TYPE_NAME (pspecs[i]));
+  g_free (pspecs);
+}
+
+static gint
+get_length (PikaProcedureConfig *config)
+{
+  GParamSpec **pspecs;
+  guint        n_pspecs;
+
+  pspecs = g_object_class_list_properties (G_OBJECT_GET_CLASS (config),
+                                           &n_pspecs);
+  g_free (pspecs);
+  g_debug ("length config: %d", n_pspecs);
+
+  return n_pspecs;
+}
+
+/* Fill a new (length zero) gva with new gvalues (empty but holding the correct type)
+ from the config.
+ */
+static void
+fill_gva_from (PikaProcedureConfig *config,
+               PikaValueArray      *gva)
+{
+  GParamSpec **pspecs;
+  guint        n_pspecs;
+
+  pspecs = g_object_class_list_properties (G_OBJECT_GET_CLASS (config),
+                                           &n_pspecs);
+  /* !!! Start at property 1 */
+  for (guint i = 1; i < n_pspecs; i++)
+    {
+      g_debug ("%s %s\n", pspecs[i]->name, G_PARAM_SPEC_TYPE_NAME (pspecs[i]));
+      /* append empty gvalue */
+      pika_value_array_append (gva, NULL);
+    }
+
+  g_free (pspecs);
+}
+
+static void
+dump_objects (PikaProcedureConfig  *config)
+{
+  /* Check it will return non-null objects. */
+  PikaValueArray *args;
+  gint length;
+
+  /* Need one less gvalue !!! */
+  args = pika_value_array_new (get_length (config) - 1);
+  /* The array still has length zero. */
+  g_debug ("GVA length: %d", pika_value_array_length (args));
+
+  fill_gva_from (config, args);
+
+  pika_procedure_config_get_values (config, args);
+  if (args == NULL)
+    {
+      g_debug ("config holds no values");
+      return;
+    }
+  length = pika_value_array_length (args);
+
+  for (guint i = 1; i < length; i++)
+    {
+      GValue *gvalue = pika_value_array_index (args, i);
+      if (G_VALUE_HOLDS_OBJECT (gvalue))
+        if (g_value_get_object (gvalue) == NULL)
+          g_debug ("gvalue %d holds NULL object", i);
+    }
+}
+
+#endif
+
+/* Run a dialog for a procedure, then interpret the script.
+ *
+ * Run dialog: create config, create dialog for config, show dialog, and return a config.
+ * Interpret: marshal config into Scheme text for function call, then interpret script.
+ *
+ * One widget per param of the procedure.
+ * Require the procedure registered with params of GTypes
+ * corresponding to SFType the author declared in script-fu-register call.
+ *
+ * Require initial_args is not NULL or empty.
+ * A caller must ensure a dialog is needed because args is not empty.
+ */
+PikaValueArray*
+script_fu_dialog_run (PikaProcedure        *procedure,
+                      SFScript             *script,
+                      PikaImage            *image,
+                      guint                 n_drawables,
+                      PikaDrawable        **drawables,
+                      const PikaValueArray *initial_args)
+
+{
+  PikaValueArray      *result = NULL;
+  PikaProcedureDialog *dialog = NULL;
+  PikaProcedureConfig *config = NULL;
+  gboolean             not_canceled;
+
+  if ( (! G_IS_OBJECT (procedure)) || script == NULL)
+    return pika_procedure_new_return_values (procedure, PIKA_PDB_EXECUTION_ERROR, NULL);
+
+  if ( pika_value_array_length (initial_args) < 1)
+    return pika_procedure_new_return_values (procedure, PIKA_PDB_EXECUTION_ERROR, NULL);
+
+  /* We don't prevent concurrent dialogs as in script-fu-interface.c.
+   * For extension-script-fu, Pika is already preventing concurrent dialogs.
+   * For pika-script-fu-interpreter, each plugin is a separate process
+   * so concurrent dialogs CAN occur.
+   */
+  /* There is no progress widget in PikaProcedureDialog.
+   * Also, we don't need to update the progress in Pika UI,
+   * because Pika shows progress: the name of all called PDB procedures.
+   */
+
+  /* Script's menu label */
+  pika_ui_init (script_fu_script_get_title (script));
+
+  config = pika_procedure_create_config (procedure);
+#if DEBUG_CONFIG_PROPERTIES
+  dump_properties (config);
+  g_debug ("Len  of initial_args %i", pika_value_array_length (initial_args) );
+#endif
+
+  /* Get saved settings (last values) into the config.
+   * Since run mode is INTERACTIVE, initial_args is moot.
+   * Instead, last used values or default values populate the config.
+   */
+  pika_procedure_config_begin_run (config, NULL, PIKA_RUN_INTERACTIVE, initial_args);
+  #if DEBUG_CONFIG_PROPERTIES
+
+    dump_objects (config);
+  #endif
+
+  /* Create a dialog having properties (describing arguments of the procedure)
+   * taken from the config.
+   *
+   * Title dialog with the menu item, not the procedure name.
+   * Assert menu item is localized.
+   */
+  dialog = (PikaProcedureDialog*) pika_procedure_dialog_new (
+                                      procedure,
+                                      config,
+                                      script_fu_script_get_title (script));
+  /* dialog has no widgets except standard buttons. */
+
+  /* It is possible to create custom widget where the provided widget is not adequate.
+   * Then pika_procedure_dialog_fill_list will create the rest.
+   * For now, the provided widgets should be adequate.
+   */
+
+  /* NULL means create widgets for all properties of the procedure
+   * that we have not already created widgets for.
+   */
+  pika_procedure_dialog_fill_list (dialog, NULL);
+
+  not_canceled = pika_procedure_dialog_run (dialog);
+  /* Assert config holds validated arg values from a user interaction. */
+
+  #if DEBUG_CONFIG_PROPERTIES
+    dump_objects (config);
+  #endif
+
+  if (not_canceled)
+    {
+      PikaValueArray *final_args = pika_value_array_copy (initial_args);
+
+      /* Store config's values into final_args. */
+      pika_procedure_config_get_values (config, final_args);
+
+      result = script_fu_interpret_image_proc (procedure, script,
+                                               image, n_drawables, drawables,
+                                               final_args);
+
+      pika_value_array_unref (final_args);
+    }
+  else
+    {
+      result = pika_procedure_new_return_values (procedure, PIKA_PDB_CANCEL, NULL);
+    }
+
+  gtk_widget_destroy ((GtkWidget*) dialog);
+
+  /* Persist config aka settings for the next run of the plugin.
+   * Passing the PikaPDBStatus from result[0].
+   * We must have a matching end_run for the begin_run, regardless of status.
+   */
+  pika_procedure_config_end_run (config, g_value_get_enum (pika_value_array_index (result, 0)));
+
+  g_object_unref (config);
+
+  return result;
+}

plug-ins/script-fu/libscriptfu/script-fu-dialog.h

@@ -0,0 +1,35 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * Copyright (C) 1995 Spencer Kimball and Peter Mattis
+ *
+ * script-fu-dialog.h
+ * Copyright (C) 2022 Lloyd Konneker
+ *
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+ #ifndef __SCRIPT_FU_DIALOG_H__
+ #define __SCRIPT_FU_DIALOG_H__
+
+PikaValueArray *script_fu_dialog_run (PikaProcedure        *procedure,
+                                      SFScript             *script,
+                                      PikaImage            *image,
+                                      guint                 n_drawables,
+                                      PikaDrawable        **drawables,
+                                      const PikaValueArray *args);
+
+#endif /* __SCRIPT_FU_DIALOG_H__ */

plug-ins/script-fu/libscriptfu/script-fu-enums.h

@@ -0,0 +1,94 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_ENUMS_H__
+#define __SCRIPT_FU_ENUMS_H__
+
+/* Note these are C names with underbar.
+ * The Scheme names are usually the same with hyphen substituted for underbar.
+ */
+
+/*  script-fu argument types  */
+typedef enum
+{
+  SF_IMAGE = 0,
+  SF_DRAWABLE,
+  SF_LAYER,
+  SF_CHANNEL,
+  SF_VECTORS,
+  SF_COLOR,
+  SF_TOGGLE,
+  SF_VALUE,
+  SF_STRING,
+  SF_ADJUSTMENT,
+  SF_FONT,
+  SF_PATTERN,
+  SF_BRUSH,
+  SF_GRADIENT,
+  SF_FILENAME,
+  SF_DIRNAME,
+  SF_OPTION,
+  SF_PALETTE,
+  SF_TEXT,
+  SF_ENUM,
+  SF_DISPLAY
+} SFArgType;
+
+typedef enum
+{
+  SF_SLIDER = 0,
+  SF_SPINNER
+} SFAdjustmentType;
+
+/* This enum is local to ScriptFu
+ * but the notion is general to other plugins.
+ *
+ * A PikaImageProcedure has drawable  arity > 1.
+ * A PikaProcedure often does not take any drawables, i.e. arity zero.
+ * Some PikaProcedure may take drawables i.e. arity > 0,
+ * but the procedure's menu item is always sensitive,
+ * and the drawable can be chosen in the plugin's dialog.
+ *
+ * Script author does not use SF-NO-DRAWABLE, for now.
+ *
+ * Scripts of class PikaProcedure are declared by script-fu-register.
+ * Their GUI is handled by ScriptFu, script-fu-interface.c
+ * An author does not declare drawable_arity.
+ *
+ * Scripts of class PikaImageProcedure are declared by script-fu-register-filter.
+ * Their GUI is handled by libpikaui, PikaProcedureDialog.
+ * Their drawable_arity is declared by the author of the script.
+ *
+ * For backward compatibility, PIKA deprecates but allows PDB procedures
+ * to take a single drawable, and sets their sensitivity automatically.
+ * Their drawable_arity is inferred by ScriptFu.
+ * FUTURE insist that an author use script-fu-register-filter (not script-fu-register)
+ * for PikaImageProcedure taking image and one or more drawables.
+ */
+typedef enum
+{
+  SF_NO_DRAWABLE = 0,       /* PikaProcedure. */
+  SF_ONE_DRAWABLE,          /* PikaImageProcedure, but only process one layer */
+  SF_ONE_OR_MORE_DRAWABLE,  /* PikaImageProcedure, multilayer capable */
+  SF_TWO_OR_MORE_DRAWABLE,  /* PikaImageProcedure, requires at least two drawables. */
+} SFDrawableArity;
+
+#endif /*  __SCRIPT_FU_ENUMS__  */

plug-ins/script-fu/libscriptfu/script-fu-errors.c

@@ -0,0 +1,242 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <glib.h>
+#include <glib-object.h>
+
+#include "tinyscheme/scheme-private.h"
+#include "script-fu-errors.h"
+
+
+/* Enable logging by "export G_MESSAGES_DEBUG=scriptfu" in the env */
+
+/* Used by debug_in_arg().
+ * FUTURE: conditional compile out when debug not enabled.
+ */
+/* These three #defines are from Tinyscheme (tinyscheme/scheme.c) */
+#define T_MASKTYPE  31
+#define typeflag(p) ((p)->_flag)
+#define type(p)     (typeflag(p)&T_MASKTYPE)
+
+  static const char *ts_types[] =
+  {
+    "T_NONE",
+    "T_STRING",    "T_NUMBER",     "T_SYMBOL",       "T_PROC",
+    "T_PAIR",      "T_CLOSURE",    "T_CONTINUATION", "T_FOREIGN",
+    "T_CHARACTER", "T_PORT",       "T_VECTOR",       "T_MACRO",
+    "T_PROMISE",   "T_ENVIRONMENT","T_ARRAY"
+  };
+
+
+/*
+ * Called on event: language error in the author's script.
+ * Logs the error and returns a foreign_error.
+ * Not all foreign_error are errors in script, some are scriptfu implementation
+ * errors or implementation errors in called procedures.
+ *
+ * This should specialize foreign_error by emphasizing script error.
+ * For now, it just specializes by also logging.
+ * foreign error does not do logging, since the caller usually logs.
+
+ * Returns a value which the caller must return to its caller.
+ */
+pointer
+script_error (scheme        *sc,
+              const gchar   *error_message,
+              const pointer  a)
+{
+  /* Logs to domain "scriptfu" since G_LOG_DOMAIN is set to that. */
+  g_debug ("%s", error_message);
+
+  /* Return message that will cross the PikaProtocol in a GError in return values
+   * to be displayed to GUI user.
+   */
+   /* FUTURE prefix with "ScriptFu: in script," */
+  return foreign_error (sc, error_message, a);
+}
+
+
+/* Specialized calls to script_error. */
+
+/* Arg has wrong type. */
+pointer
+script_type_error (scheme       *sc,
+                   const gchar  *expected_type,
+                   const guint   arg_index,
+                   const gchar  *proc_name)
+{
+  gchar  error_message[1024];
+
+  g_snprintf (error_message, sizeof (error_message),
+              "in script, expected type: %s for argument %d to %s ",
+              expected_type, arg_index+1, proc_name );
+
+  return script_error (sc, error_message, 0);
+}
+
+/* Arg is container (list or vector) having an element of wrong type. */
+pointer
+script_type_error_in_container (scheme        *sc,
+                                const gchar   *expected_type,
+                                const guint    arg_index,
+                                const guint    element_index,
+                                const gchar   *proc_name,
+                                const pointer  container)
+{
+  gchar     error_message[1024];
+
+  /* convert zero based indices to ordinals */
+  g_snprintf (error_message, sizeof (error_message),
+              "in script, expected type: %s for element %d of argument %d to %s ",
+              expected_type, element_index+1, arg_index+1, proc_name );
+
+  /* pass container to foreign_error */
+  return script_error (sc, error_message, container);
+}
+
+/* Arg is vector of wrong length. !!! Arg is not a list.  */
+pointer
+script_length_error_in_vector (scheme       *sc,
+                               const guint   arg_index,
+                               const gchar  *proc_name,
+                               const guint   expected_length,
+                               const pointer vector)
+{
+  gchar    error_message[1024];
+
+  /* vector_length returns signed long (???) but expected_length is unsigned */
+  g_snprintf (error_message, sizeof (error_message),
+              "in script, vector (argument %d) for function %s has "
+              "length %ld but expected length %u",
+              arg_index+1, proc_name,
+              sc->vptr->vector_length (vector), expected_length);
+
+  /* not pass vector to foreign_error */
+  return script_error (sc, error_message, 0);
+}
+
+
+/* Thin wrapper around foreign_error.
+ * Does logging.
+ * Names a kind of error: in ScriptFu code, or in external code.
+ * Same as script_error, but FUTURE distinguish the message with a prefix.
+ */
+pointer
+implementation_error (scheme       *sc,
+                      const gchar  *error_message,
+                      const pointer a)
+{
+  g_debug ("%s", error_message);
+  return foreign_error (sc, error_message, a);
+}
+
+
+/* Debug helpers.
+ * Enabled by G_MESSAGES_DEBUG=scriptfu env var.
+ * FUTURE: For performance, return early if not debugging.
+ * Or conditionally compile.
+ */
+
+void
+debug_vector (scheme        *sc,
+              const pointer  vector,
+              const char    *format)
+{
+  glong count = sc->vptr->vector_length (vector);
+
+  g_debug ("vector has %ld elements", count);
+  if (count > 0)
+    {
+      for (int j = 0; j < count; ++j)
+        {
+          if (strcmp (format, "%f")==0)
+            /* real i.e. float */
+            g_debug (format,
+                     sc->vptr->rvalue ( sc->vptr->vector_elem (vector, j) ));
+          else
+            /* integer */
+            g_debug (format,
+                     sc->vptr->ivalue ( sc->vptr->vector_elem (vector, j) ));
+          /* FUTURE vectors of strings or other formats? */
+        }
+    }
+}
+
+/* TinyScheme has no polymorphic length(), elem() methods on containers.
+ * Must walk a list with car/cdr.
+ *
+ * Unlike vectors, lists have a guint length, not gulong
+ *
+ * !!! Only for lists of strings.
+ */
+void
+debug_list (scheme       *sc,
+            pointer       list,
+            const char   *format,
+            const guint   num_elements)
+{
+  g_return_if_fail (num_elements == sc->vptr->list_length (sc, list));
+  g_debug ("list has %d elements", num_elements);
+  if (num_elements > 0)
+    {
+      for (int j = 0; j < num_elements; ++j)
+        {
+          pointer v_element = sc->vptr->pair_car (list);
+
+          g_debug (format,
+                   sc->vptr->string_value ( v_element ));
+          list = sc->vptr->pair_cdr (list);
+        }
+    }
+}
+
+/* Understands the adapted type system: Scheme interpreter type system.
+ * Log types of formal and actual args.
+ * Scheme type names, and enum of actual type.
+ */
+void
+debug_in_arg (scheme           *sc,
+              const pointer     a,
+              const guint       arg_index,
+              const gchar      *type_name )
+{
+  g_debug ("param %d - expecting type %s", arg_index + 1, type_name );
+  g_debug ("actual arg is type %s (%d)",
+           ts_types[ type(sc->vptr->pair_car (a)) ],
+           type(sc->vptr->pair_car (a)));
+}
+
+/* Log GValue: its value and its GType
+ * FUTURE: for Pika types, pika_item_get_id (PIKA_ITEM (<value>)));
+ */
+void
+debug_gvalue (const GValue     *value)
+{
+  char        *contents_str;
+  const char  *type_name;
+
+  type_name = G_VALUE_TYPE_NAME(value);
+  contents_str = g_strdup_value_contents (value);
+  g_debug ("Value: %s Type: %s", contents_str, type_name);
+  g_free (contents_str);
+}

plug-ins/script-fu/libscriptfu/script-fu-errors.h

@@ -0,0 +1,68 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_ERRORS_H__
+#define __SCRIPT_FU_ERRORS_H__
+
+pointer script_error (scheme        *sc,
+                      const gchar   *error_message,
+                      const pointer  a);
+
+pointer script_type_error (scheme       *sc,
+                           const gchar  *expected_type,
+                           const guint   arg_index,
+                           const gchar  *proc_name);
+
+pointer script_type_error_in_container (scheme       *sc,
+                                        const gchar  *expected_type,
+                                        const guint   arg_index,
+                                        const guint   element_index,
+                                        const gchar  *proc_name,
+                                        const pointer a);
+
+pointer script_length_error_in_vector (scheme       *sc,
+                                       const guint   arg_index,
+                                       const gchar  *proc_name,
+                                       const guint   expected_length,
+                                       const pointer vector);
+
+pointer implementation_error (scheme        *sc,
+                              const gchar   *error_message,
+                              const pointer  a);
+
+
+void debug_vector (scheme        *sc,
+                   const pointer  vector,
+                   const gchar   *format);
+
+void debug_list (scheme       *sc,
+                 pointer       list,
+                 const char   *format,
+                 const guint   num_elements);
+
+void debug_in_arg(scheme           *sc,
+                  const pointer     a,
+                  const guint       arg_index,
+                  const gchar      *type_name );
+
+void debug_gvalue(const GValue     *value);
+
+#endif /*  __SCRIPT_FU_ERRORS_H__  */

plug-ins/script-fu/libscriptfu/script-fu-interface.h

@@ -0,0 +1,32 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_INTERFACE_H__
+#define __SCRIPT_FU_INTERFACE_H__
+
+
+PikaPDBStatusType  script_fu_interface           (SFScript     *script,
+                                                  gint          start_arg);
+void               script_fu_interface_report_cc (const gchar  *command);
+gboolean           script_fu_interface_is_active (void);
+
+
+#endif /*  __SCRIPT_FU_INTERFACE_H__  */

plug-ins/script-fu/libscriptfu/script-fu-intl.h

@@ -0,0 +1,49 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * Copyright (C) 1995 Spencer Kimball and Peter Mattis
+ *
+ * script-fu-intl.h
+ *
+ * This library 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 of the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library.  If not, see
+ * <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_INTL_H__
+#define __SCRIPT_FU_INTL_H__
+
+#ifndef GETTEXT_PACKAGE
+#error "config.h must be included prior to script-fu-intl.h"
+#endif
+
+#include <glib/gi18n.h>
+
+
+#define DEFINE_STD_SET_I18N                                          \
+static gboolean                                                      \
+set_i18n (PikaPlugIn   *plug_in,                                     \
+          const gchar  *procedure_name,                              \
+          gchar       **gettext_domain,                              \
+          gchar       **catalog_dir)                                 \
+{                                                                    \
+  *gettext_domain = g_strdup (GETTEXT_PACKAGE"-script-fu");       \
+  return TRUE;                                                       \
+};
+
+#define STD_SET_I18N set_i18n
+
+
+#endif /* __SCRIPT_FU_INTL_H__ */

plug-ins/script-fu/libscriptfu/script-fu-lib.c

@@ -0,0 +1,224 @@
+
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <libpika/pika.h>
+
+#include "script-fu-lib.h"
+
+#include "script-fu-types.h"     /* SFScript */
+#include "scheme-wrapper.h"      /* tinyscheme_init etc, */
+#include "script-fu-scripts.h"   /* script_fu_find_scripts */
+#include "script-fu-interface.h" /* script_fu_interface_is_active */
+#include "script-fu-proc-factory.h"
+
+
+/*
+ * The purpose here is a small, clean API to the exported functions of the library,
+ * hiding internal types of the library
+ * and hiding functions not static but not exported.
+ *
+ * Some are simple delegation to scheme_wrapper functions,
+ * but others adapt
+ * and some call functions not in scheme_wrapper.c
+ */
+
+
+/*
+ * Return whether extension-script-fu has an open dialog.
+ * extension-script-fu is a single process.
+ * It cannot have concurrent dialogs open in the PIKA app.
+ *
+ * Other plugins implementing PLUGIN type PDB procedures
+ * in their own process (e.g. pika-scheme-interpreter) do not need this.
+ */
+gboolean
+script_fu_extension_is_busy (void)
+{
+  return script_fu_interface_is_active ();
+}
+
+/*
+ * Find files at given paths, load them into the interpreter,
+ * and register them as PDB procs of type TEMPORARY,
+ * owned by the PDB proc of type PLUGIN for the given plugin.
+ */
+void
+script_fu_find_and_register_scripts ( PikaPlugIn     *plugin,
+                                      GList          *paths)
+{
+  script_fu_find_scripts (plugin, paths);
+}
+
+/*
+ * Init the embedded interpreter.
+ *
+ * allow_register:
+ * TRUE: allow loaded scripts to register PDB procedures.
+ * The scheme functions script-fu-register and script-fu-menu-register are
+ * defined to do something.
+ * FALSE:  The scheme functions script-fu-register and script-fu-menu-register are
+ * defined but do nothing.
+ *
+ * Note that the embedded interpreter always defines scheme functions
+ * for all PDB procedures already existing when the interpreter starts
+ * (currently bound at startup, but its possible to lazy bind.)
+ * allow_register doesn't affect that.
+ */
+void
+script_fu_init_embedded_interpreter ( GList          *paths,
+                                      gboolean        allow_register,
+                                      PikaRunMode     run_mode)
+{
+  g_debug ("script_fu_init_embedded_interpreter");
+  tinyscheme_init (paths, allow_register);
+  ts_set_run_mode (run_mode);
+  /*
+   * Ensure the embedded interpreter is running
+   * and has loaded its internal Scheme scripts
+   * and has defined existing PDB procs as Scheme foreign functions
+   * (is ready to interpret PDB-like function calls in scheme scripts.)
+   *
+   * scripts/...init and scripts/...compat.scm are loaded
+   * iff paths includes the "/scripts" dir.
+   *
+   * The .scm file(s) for plugins are loaded
+   * iff paths includes their parent directory (e.g. /scripts)
+   * Loaded does not imply yet registered in the PDB
+   * (yet, they soon might be for some phases of the plugin.)
+   */
+}
+
+void
+script_fu_set_print_flag  (gboolean should_print)
+{
+  ts_set_print_flag (should_print);
+}
+
+/*
+ * Make tinyscheme begin writing output to given gstring.
+ */
+void
+script_fu_redirect_output_to_gstr (GString *output)
+{
+  ts_register_output_func (ts_gstring_output_func, output);
+}
+
+void
+script_fu_redirect_output_to_stdout (void)
+{
+  ts_register_output_func (ts_stdout_output_func, NULL);
+}
+
+void
+script_fu_print_welcome (void)
+{
+  ts_print_welcome ();
+}
+
+gboolean
+script_fu_interpret_string (const gchar *text)
+{
+  /*converting from enum to boolean */
+  return (gboolean) ts_interpret_string (text);
+}
+
+void
+script_fu_set_run_mode (PikaRunMode run_mode)
+{
+  ts_set_run_mode (run_mode);
+}
+
+const gchar *
+script_fu_get_success_msg (void)
+{
+  return ts_get_success_msg ();
+}
+
+void
+script_fu_run_read_eval_print_loop (void)
+{
+  ts_interpret_stdin ();
+}
+
+void
+script_fu_register_quit_callback (void (*func) (void))
+{
+  ts_register_quit_callback (func);
+}
+
+void
+script_fu_register_post_command_callback (void (*func) (void))
+{
+  ts_register_post_command_callback (func);
+}
+
+/*
+ * Return list of paths to directories containing .scm and .init scripts.
+ * Usually at least PIKA's directory named like "/scripts."
+ * List can also contain dirs custom or private to a user.
+ " The PIKA dir often contain: plugins, init scripts, and utility scripts.
+ *
+ * Caller must free the returned list.
+ */
+GList *
+script_fu_search_path (void)
+{
+  gchar *path_str;
+  GList *path = NULL;
+
+  path_str = pika_pikarc_query ("script-fu-path");
+  if (path_str)
+    {
+      GError *error = NULL;
+
+      path = pika_config_path_expand_to_files (path_str, &error);
+      g_free (path_str);
+
+      if (! path)
+        {
+          g_warning ("Can't convert script-fu-path to filesystem encoding: %s",
+                     error->message);
+          g_clear_error (&error);
+        }
+    }
+  return path;
+}
+
+
+PikaProcedure *
+script_fu_find_scripts_create_PDB_proc_plugin (PikaPlugIn  *plug_in,
+                                               GList       *paths,
+                                               const gchar *name)
+{
+  /* Delegate to factory. */
+  return script_fu_proc_factory_make_PLUGIN (plug_in, paths, name);
+}
+
+GList *
+script_fu_find_scripts_list_proc_names (PikaPlugIn *plug_in,
+                                        GList      *paths)
+{
+  /* Delegate to factory. */
+  return script_fu_proc_factory_list_names (plug_in, paths);
+}

plug-ins/script-fu/libscriptfu/script-fu-lib.h

@@ -0,0 +1,55 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_LIB_H__
+#define __SCRIPT_FU_LIB_H__
+
+gboolean     script_fu_extension_is_busy         (void);
+
+GList *      script_fu_search_path               (void);
+void         script_fu_find_and_register_scripts (PikaPlugIn     *plugin,
+                                                  GList          *paths);
+
+void         script_fu_set_run_mode              (PikaRunMode     run_mode);
+void         script_fu_init_embedded_interpreter (GList          *paths,
+                                                  gboolean        allow_register,
+                                                  PikaRunMode     run_mode);
+
+void         script_fu_set_print_flag            (gboolean        should_print);
+void         script_fu_redirect_output_to_gstr   (GString        *output);
+void         script_fu_redirect_output_to_stdout (void);
+void         script_fu_print_welcome             (void);
+
+gboolean     script_fu_interpret_string          (const gchar     *text);
+const gchar *script_fu_get_success_msg           (void);
+
+void         script_fu_run_read_eval_print_loop  (void);
+
+void         script_fu_register_quit_callback         (void (*func) (void));
+void         script_fu_register_post_command_callback (void (*func) (void));
+
+PikaProcedure *script_fu_find_scripts_create_PDB_proc_plugin (PikaPlugIn  *plug_in,
+                                                              GList       *paths,
+                                                              const gchar *name);
+GList         *script_fu_find_scripts_list_proc_names        (PikaPlugIn  *plug_in,
+                                                              GList       *paths);
+
+#endif /* __SCRIPT_FU_LIB_H__ */

plug-ins/script-fu/libscriptfu/script-fu-proc-factory.c

@@ -0,0 +1,207 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+#include <glib.h>
+#include <libpika/pika.h>
+
+#include "tinyscheme/scheme-private.h"
+#include "script-fu-types.h"
+#include "script-fu-scripts.h"
+#include "script-fu-script.h"
+
+#include "script-fu-proc-factory.h"
+
+/* Local functions */
+static void  script_fu_add_menu_to_procedure (PikaProcedure *procedure,
+                                              SFScript      *script);
+
+
+/* Methods to register PDB procs. A factory makes objects, here PDB procedures.
+ *
+ * Used by the outer script-fu-interpreter
+ *
+ * This is in libscriptfu to hide the SFScript type from outer plugins.
+ * These methods use instances of type SFScript as specs for procedures.
+ *
+ * FUTURE: migrate code.
+ * There are two flavors of factory-like code: for PDBProcType TEMPORARY and PLUGIN.
+ * extension-script-fu outer plugin only makes TEMPORARY
+ * script-fu-interpreter outer plugin only makes PLUGIN type
+ * This source file supports only script-fu-interpreter.
+ * script_fu_find_scripts() in script-fu-scripts.c is also a factory-like method,
+ * and could be extracted to a separate source file.
+ * Maybe more code sharing between the two flavors.
+ */
+
+
+/* Create and return a single PDB procedure of type PLUGIN,
+ * for the given proc name, by reading the script file in the given paths.
+ * Also add a menu for the procedure.
+ *
+ * PDB proc of type PLUGIN has permanent lifetime, unlike type TEMPORARY.
+ *
+ * The list of paths is usually just one directory, a subdir of /plug-ins.
+ * The directory may contain many .scm files.
+ * The plugin manager only queries one .scm file,
+ * having the same name as its parent dir and and having execute permission.
+ * But here we read all the .scm files in the directory.
+ * Each .scm file may register (and define run func for) many PDB procedures.
+ *
+ * Here, one name is passed, and though we load all the .scm files,
+ * we only create a PDB procedure for the passed name.
+ */
+PikaProcedure *
+script_fu_proc_factory_make_PLUGIN (PikaPlugIn  *plug_in,
+                                    GList       *paths,
+                                    const gchar *proc_name)
+{
+  SFScript      * script    = NULL;
+  PikaProcedure * procedure = NULL;
+
+  /* Reads all .scm files at paths, even though only one is pertinent.
+   * The returned script_tree is also in the state of the interpreter,
+   * we don't need the result here.
+  */
+  (void) script_fu_find_scripts_into_tree (plug_in, paths);
+
+  /* Get the pertinent script from the tree. */
+  script = script_fu_find_script (proc_name);
+
+  if (script)
+    {
+      procedure = script_fu_script_create_PDB_procedure (
+        plug_in,
+        script,
+        PIKA_PDB_PROC_TYPE_PLUGIN);
+      script_fu_add_menu_to_procedure (procedure, script);
+    }
+  else
+    {
+      g_warning ("Failed to find script: %s.", proc_name);
+    }
+  return procedure;
+}
+
+ /* Traverse the list of scripts, for each defined name of a PDB proc,
+  * add it list whose handle is given.
+  *
+  * Order is not important.  Could just as well prepend.
+  *
+  * This is a GTraverseFunction
+  */
+static gboolean
+script_fu_append_script_names (gpointer      *foo G_GNUC_UNUSED,
+                               GList         *scripts,
+                               GList        **name_list)
+{
+  for (GList * list = scripts; list; list = g_list_next (list))
+    {
+      SFScript *script   = list->data;
+
+      if ( !script_fu_is_defined (script->name))
+        {
+          g_warning ("Run function not defined, or does not match PDB procedure name: %s",
+                     script->name);
+          continue;
+        }
+
+      /* Must assign result from g_list_append back to name_list */
+      *name_list = g_list_append ( (GList *) *name_list, g_strdup (script->name));
+    }
+  return FALSE; /* We traversed all. */
+ }
+
+/* Load script texts (.scm files) in the given paths.
+ * Iterate over all loaded scripts to get the PDB proc names they define.
+ * Return a list of the names.
+ */
+GList *
+script_fu_proc_factory_list_names (PikaPlugIn *plug_in,
+                                   GList      *paths)
+{
+  GList * result_list = NULL;
+  GTree * script_tree = NULL;
+
+  /* Load (eval) all .scm files in all dirs in paths. */
+  script_tree = script_fu_find_scripts_into_tree (plug_in, paths);
+
+  /* Iterate over the tree, adding each script name to result list */
+  g_tree_foreach (script_tree,
+                  (GTraverseFunc) script_fu_append_script_names,
+                  &result_list);
+
+  return result_list;
+}
+
+/* From scriptfu's internal data, add any menu to given procedure in the PDB.
+ * Requires that a script was just eval'ed so that scriptfu's list of menus
+ * declared in a script is valid.
+ * Requires the proc exists in PDB.
+ *
+ * Not ensure the PDB proc has a menu, when no menu was defined in the script.
+ *
+ * Derived from script_fu_install_menu, but that is specific to TEMPORARY procs.
+ * Also, unlike script_fu_install_menu, we don't nuke the menu list as we proceed.
+ *
+ * For each "create" of a procedure, the pika-script-fu-interpreter is started anew,
+ * and a new script_menu_list is derived from the .scm file.
+ * We don't traverse the menu list more than once per session, which soon exits.
+ */
+static void
+script_fu_add_menu_to_procedure (PikaProcedure *procedure,
+                                  SFScript      *script)
+{
+  GList    *menu_list;
+  gboolean  did_add_menu = FALSE;
+
+  menu_list = script_fu_get_menu_list ();
+  /* menu_list might be NULL: for loop will have no iterations. */
+
+  /* Each .scm file can declare many menu paths.
+   * Traverse the list to find the menu path defined for the procedure.
+   * Each SFMenu points to the procedure (SFScript) it belongs to.
+   */
+  for (GList * traverser = menu_list; traverser; traverser = g_list_next (traverser))
+    {
+      SFMenu *menu = traverser->data;
+      if (menu->script == script)
+        {
+          g_debug ("Add menu: %s", menu->menu_path);
+          pika_procedure_add_menu_path (procedure, menu->menu_path);
+          did_add_menu = TRUE;
+          break;
+        }
+    }
+
+  /* Some procedures don't have menu path.
+   * It is normal, but not common, to define procs of type PLUGIN that don't appear in the menus.
+   * No part of PIKA defaults a menu path for procedures.
+   * A menu label without a menu path is probably a mistake by the script author.
+   */
+  if ( ! did_add_menu )
+    {
+      /* Unusual for a .scm file to have no menu paths, but not an error. */
+      g_debug ("No menu paths! Does the procedure name in script-fu-menu-register match?");
+      /* FUTURE if the script defines a menu *label*, declare an error. */
+    }
+  /* script_menu_list is a reference we do not need to free. */
+ }

plug-ins/script-fu/libscriptfu/script-fu-proc-factory.h

@@ -0,0 +1,31 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_PDB_PROC_FACTORY_H__
+#define __SCRIPT_FU_PDB_PROC_FACTORY_H__
+
+PikaProcedure *script_fu_proc_factory_make_PLUGIN (PikaPlugIn  *plug_in,
+                                                   GList       *paths,
+                                                   const gchar *name);
+GList         *script_fu_proc_factory_list_names  (PikaPlugIn  *plug_in,
+                                                   GList       *paths);
+
+#endif /*  __SCRIPT_FU_PDB_PROC_FACTORY__  */

plug-ins/script-fu/libscriptfu/script-fu-regex.c

@@ -0,0 +1,183 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+/* Based on re.c
+ *
+ * Henry Spencer's implementation of Regular Expressions,
+ * used for TinyScheme
+ *
+ * Refurbished by Stephen Gildea
+ *
+ * Ported to GRegex and de-uglified by Michael Natterer
+ */
+
+#include "config.h"
+
+#include "tinyscheme/scheme-private.h"
+#include "script-fu-regex.h"
+
+
+/*  local function prototypes  */
+
+static pointer foreign_re_match (scheme  *sc,
+                                 pointer  args);
+static void    set_vector_elem  (pointer  vec,
+                                 int      ielem,
+                                 pointer  newel);
+
+
+/*  public functions  */
+
+void
+script_fu_regex_init (scheme *sc)
+{
+  sc->vptr->scheme_define (sc,
+                           sc->global_env,
+                           sc->vptr->mk_symbol(sc,"re-match"),
+                           sc->vptr->mk_foreign_func(sc, foreign_re_match));
+
+#if 0
+  sc->vptr->load_string
+    (sc,
+     ";; return the substring of STRING matched in MATCH-VECTOR,\n"
+     ";; the Nth subexpression match (default 0).\n"
+     "\n"
+     "(define (re-match-nth string match-vector . n)\n"
+     "  (let ((n (if (pair? n) (car n) 0)))\n"
+     "    (substring string (car (vector-ref match-vector n))\n"
+     "                      (cdr (vector-ref match-vector n)))))\n"
+     "(define (re-before-nth string match-vector . n)\n"
+     "  (let ((n (if (pair? n) (car n) 0)))\n"
+     "    (substring string 0 (car (vector-ref match-vector n)))))\n"
+     "(define (re-after-nth string match-vector . n)\n"
+     "  (let ((n (if (pair? n) (car n) 0)))\n"
+     "    (substring string (cdr (vector-ref match-vector n))\n"
+     "                      (string-length string))))\n");
+#endif
+}
+
+
+/*  private functions  */
+
+static pointer
+foreign_re_match (scheme  *sc,
+                  pointer  args)
+{
+  pointer   retval = sc->F;
+  gboolean  success;
+  gboolean  is_valid_utf8;
+  GRegex   *regex;
+  pointer   first_arg, second_arg;
+  pointer   third_arg = sc->NIL;
+  char     *string;
+  char     *pattern;
+  int       num = 0;
+
+  if (!((args != sc->NIL)
+        && sc->vptr->is_string ((first_arg = sc->vptr->pair_car (args)))
+        && (args = sc->vptr->pair_cdr (args))
+        && sc->vptr->is_pair (args)
+        && sc->vptr->is_string ((second_arg = sc->vptr->pair_car (args)))))
+    {
+      return sc->F;
+    }
+
+  pattern = sc->vptr->string_value (first_arg);
+  string  = sc->vptr->string_value (second_arg);
+
+  is_valid_utf8 = g_utf8_validate (string, -1, NULL);
+
+  args = sc->vptr->pair_cdr (args);
+
+  if (args != sc->NIL)
+    {
+      if (!(sc->vptr->is_pair (args)
+            && sc->vptr->is_vector ((third_arg = sc->vptr->pair_car (args)))))
+        {
+          return sc->F;
+        }
+      else
+        {
+          num = third_arg->_object._number.value.ivalue;
+        }
+    }
+
+  regex = g_regex_new (pattern, G_REGEX_EXTENDED, 0, NULL);
+  if (! regex)
+    return sc->F;
+
+  if (! num)
+    {
+      success = g_regex_match (regex, string, 0, NULL);
+    }
+  else
+    {
+      GMatchInfo *match_info;
+      gint        i;
+
+      success = g_regex_match (regex, string, 0, &match_info);
+
+      for (i = 0; i < num; i++)
+        {
+          gint start, end;
+
+          g_match_info_fetch_pos (match_info, i, &start, &end);
+
+          if (is_valid_utf8)
+            {
+              start = g_utf8_pointer_to_offset (string, string + start);
+              end   = g_utf8_pointer_to_offset (string, string + end);
+            }
+
+#undef cons
+          set_vector_elem (third_arg, i,
+                           sc->vptr->cons(sc,
+                                          sc->vptr->mk_integer(sc, start),
+                                          sc->vptr->mk_integer(sc, end)));
+        }
+
+      g_match_info_free (match_info);
+    }
+
+  if (success)
+    retval = sc->T;
+
+  g_regex_unref (regex);
+
+  return retval;
+}
+
+static void
+set_vector_elem (pointer vec,
+                 int     ielem,
+                 pointer newel)
+{
+  int n = ielem / 2;
+
+  if (ielem % 2 == 0)
+    {
+      vec[1 + n]._object._cons._car = newel;
+    }
+  else
+    {
+      vec[1 + n]._object._cons._cdr = newel;
+    }
+}

plug-ins/script-fu/libscriptfu/script-fu-regex.h

@@ -0,0 +1,29 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_REGEX_H__
+#define __SCRIPT_FU_REGEX_H__
+
+
+void   script_fu_regex_init (scheme *sc);
+
+
+#endif /* __SCRIPT_FU_REGEX_H__ */

plug-ins/script-fu/libscriptfu/script-fu-register.c

@@ -0,0 +1,474 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <glib.h>
+
+#ifdef G_OS_WIN32
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#endif
+
+#include <libpika/pika.h>
+
+#include "tinyscheme/scheme-private.h"
+
+#include "script-fu-types.h"
+#include "script-fu-script.h"
+#include "script-fu-register.h"
+
+/* Methods for a script's call to script-fu-register or script-fu-register-filter.
+ * Such calls declare a PDB procedure, that ScriptFu will register in the PDB,
+ * that the script implements by its inner run func.
+ * These methods are only creating structs local to ScriptFu, used later to register.
+ */
+
+
+
+/* Traverse Scheme argument list
+ * creating a new SFScript with metadata, but empty SFArgs (formal arg specs)
+ *
+ * Takes a handle to a pointer into the argument list.
+ * Advances the pointer past the metadata args.
+ *
+ * Returns new SFScript.
+ */
+SFScript*
+script_fu_script_new_from_metadata_args (scheme  *sc,
+                                         pointer *handle)
+{
+  SFScript    *script;
+  const gchar *name;
+  const gchar *menu_label;
+  const gchar *blurb;
+  const gchar *author;
+  const gchar *copyright;
+  const gchar *date;
+  const gchar *image_types;
+  guint        n_args;
+
+  /* dereference handle into local pointer. */
+  pointer a = *handle;
+
+  g_debug ("script_fu_script_new_from_metadata_args");
+
+  /* Require list_length starting at a is >=7
+   * else strange parsing errors at plugin query time.
+   */
+
+  name = sc->vptr->string_value (sc->vptr->pair_car (a));
+  a = sc->vptr->pair_cdr (a);
+  menu_label = sc->vptr->string_value (sc->vptr->pair_car (a));
+  a = sc->vptr->pair_cdr (a);
+  blurb = sc->vptr->string_value (sc->vptr->pair_car (a));
+  a = sc->vptr->pair_cdr (a);
+  author = sc->vptr->string_value (sc->vptr->pair_car (a));
+  a = sc->vptr->pair_cdr (a);
+  copyright = sc->vptr->string_value (sc->vptr->pair_car (a));
+  a = sc->vptr->pair_cdr (a);
+  date = sc->vptr->string_value (sc->vptr->pair_car (a));
+  a = sc->vptr->pair_cdr (a);
+
+  if (sc->vptr->is_pair (a))
+    {
+      image_types = sc->vptr->string_value (sc->vptr->pair_car (a));
+      a = sc->vptr->pair_cdr (a);
+    }
+  else
+    {
+      image_types = sc->vptr->string_value (a);
+      a = sc->NIL;
+    }
+
+  /* Store local, advanced pointer at handle from caller. */
+  *handle = a;
+
+  /* Calculate supplied number of formal arguments of the PDB procedure,
+   * each takes three actual args from Scheme call.
+   */
+  n_args = sc->vptr->list_length (sc, a) / 3;
+
+  /* This allocates empty array of SFArg. Hereafter, script knows its n_args. */
+  script = script_fu_script_new (name,
+                                 menu_label,
+                                 blurb,
+                                 author,
+                                 copyright,
+                                 date,
+                                 image_types,
+                                 n_args);
+  return script;
+}
+
+/* Traverse suffix of Scheme argument list,
+ * creating SFArgs (formal arg specs) from triplets.
+ *
+ * Takes a handle to a pointer into the argument list.
+ * Advances the pointer past the triplets.
+ * Changes state of SFScript.args[]
+ *
+ * Returns a foreign_error or NIL.
+ */
+pointer
+script_fu_script_create_formal_args (scheme   *sc,
+                                     pointer  *handle,
+                                     SFScript *script)
+{
+  /* dereference handle into local pointer. */
+  pointer a = *handle;
+
+  g_debug ("script_fu_script_create_formal_args");
+
+  for (guint i = 0; i < script->n_args; i++)
+    {
+      SFArg *arg = &script->args[i];
+
+      if (a != sc->NIL)
+        {
+          if (!sc->vptr->is_integer (sc->vptr->pair_car (a)))
+            return foreign_error (sc, "script-fu-register: argument types must be integer values", 0);
+
+          arg->type = sc->vptr->ivalue (sc->vptr->pair_car (a));
+          a = sc->vptr->pair_cdr (a);
+        }
+      else
+        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 foreign_error (sc, "script-fu-register: argument labels must be strings", 0);
+
+          arg->label = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+          a = sc->vptr->pair_cdr (a);
+        }
+      else
+        return foreign_error (sc, "script-fu-register: missing arguments label", 0);
+
+      if (a != sc->NIL)
+        {
+          switch (arg->type)
+            {
+            case SF_IMAGE:
+            case SF_DRAWABLE:
+            case SF_LAYER:
+            case SF_CHANNEL:
+            case SF_VECTORS:
+            case SF_DISPLAY:
+              if (!sc->vptr->is_integer (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: default IDs must be integer values", 0);
+
+              arg->default_value.sfa_image =
+                sc->vptr->ivalue (sc->vptr->pair_car (a));
+              break;
+
+            case SF_COLOR:
+              if (sc->vptr->is_string (sc->vptr->pair_car (a)))
+                {
+                  if (! pika_rgb_parse_css (&arg->default_value.sfa_color,
+                                            sc->vptr->string_value (sc->vptr->pair_car (a)),
+                                            -1))
+                    return foreign_error (sc, "script-fu-register: invalid default color name", 0);
+
+                  pika_rgb_set_alpha (&arg->default_value.sfa_color, 1.0);
+                }
+              else if (sc->vptr->is_list (sc, sc->vptr->pair_car (a)) &&
+                       sc->vptr->list_length(sc, sc->vptr->pair_car (a)) == 3)
+                {
+                  pointer color_list;
+                  guchar  r, g, b;
+
+                  color_list = sc->vptr->pair_car (a);
+                  r = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)), 0, 255);
+                  color_list = sc->vptr->pair_cdr (color_list);
+                  g = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)), 0, 255);
+                  color_list = sc->vptr->pair_cdr (color_list);
+                  b = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)), 0, 255);
+
+                  pika_rgb_set_uchar (&arg->default_value.sfa_color, r, g, b);
+                }
+              else
+                {
+                  return foreign_error (sc, "script-fu-register: color defaults must be a list of 3 integers or a color name", 0);
+                }
+              break;
+
+            case SF_TOGGLE:
+              if (!sc->vptr->is_integer (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: toggle default must be an integer value", 0);
+
+              arg->default_value.sfa_toggle =
+                (sc->vptr->ivalue (sc->vptr->pair_car (a))) ? TRUE : FALSE;
+              break;
+
+            case SF_VALUE:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: value defaults must be string values", 0);
+
+              arg->default_value.sfa_value =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+              break;
+
+            case SF_STRING:
+            case SF_TEXT:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: string defaults must be string values", 0);
+
+              arg->default_value.sfa_value =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+              break;
+
+            case SF_ADJUSTMENT:
+              {
+                pointer adj_list;
+
+                if (!sc->vptr->is_list (sc, a))
+                  return foreign_error (sc, "script-fu-register: adjustment defaults must be a list", 0);
+
+                adj_list = sc->vptr->pair_car (a);
+                arg->default_value.sfa_adjustment.value =
+                  sc->vptr->rvalue (sc->vptr->pair_car (adj_list));
+
+                adj_list = sc->vptr->pair_cdr (adj_list);
+                arg->default_value.sfa_adjustment.lower =
+                  sc->vptr->rvalue (sc->vptr->pair_car (adj_list));
+
+                adj_list = sc->vptr->pair_cdr (adj_list);
+                arg->default_value.sfa_adjustment.upper =
+                  sc->vptr->rvalue (sc->vptr->pair_car (adj_list));
+
+                adj_list = sc->vptr->pair_cdr (adj_list);
+                arg->default_value.sfa_adjustment.step =
+                  sc->vptr->rvalue (sc->vptr->pair_car (adj_list));
+
+                adj_list = sc->vptr->pair_cdr (adj_list);
+                arg->default_value.sfa_adjustment.page =
+                  sc->vptr->rvalue (sc->vptr->pair_car (adj_list));
+
+                adj_list = sc->vptr->pair_cdr (adj_list);
+                arg->default_value.sfa_adjustment.digits =
+                  sc->vptr->ivalue (sc->vptr->pair_car (adj_list));
+
+                adj_list = sc->vptr->pair_cdr (adj_list);
+                arg->default_value.sfa_adjustment.type =
+                  sc->vptr->ivalue (sc->vptr->pair_car (adj_list));
+              }
+              break;
+
+            case SF_FILENAME:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                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 foreign_error (sc, "script-fu-register: dirname defaults must be string values", 0);
+
+              arg->default_value.sfa_file.filename =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+
+#ifdef G_OS_WIN32
+              {
+                /* Replace POSIX slashes with Win32 backslashes. This
+                 * is just so script-fus can be written with only
+                 * POSIX directory separators.
+                 */
+                gchar *filename = arg->default_value.sfa_file.filename;
+
+                while (*filename)
+                  {
+                    if (*filename == '/')
+                      *filename = G_DIR_SEPARATOR;
+
+                    filename++;
+                  }
+              }
+#endif
+              break;
+
+            case SF_FONT:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: font defaults must be string values", 0);
+
+              arg->default_value.sfa_font =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+              break;
+
+            case SF_PALETTE:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: palette defaults must be string values", 0);
+
+              arg->default_value.sfa_palette =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+              break;
+
+            case SF_PATTERN:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: pattern defaults must be string values", 0);
+
+              arg->default_value.sfa_pattern =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+              break;
+
+            case SF_BRUSH:
+              {
+                pointer brush_list;
+
+                if (!sc->vptr->is_list (sc, a))
+                  return foreign_error (sc, "script-fu-register: brush defaults must be a list", 0);
+
+                #ifdef OLD
+                temporarily, still a list, but use only the name
+                future: not a list, only a name
+
+                brush_list = sc->vptr->pair_car (a);
+                arg->default_value.sfa_brush.name =
+                  g_strdup (sc->vptr->string_value (sc->vptr->pair_car (brush_list)));
+
+                brush_list = sc->vptr->pair_cdr (brush_list);
+                arg->default_value.sfa_brush.opacity =
+                  sc->vptr->rvalue (sc->vptr->pair_car (brush_list));
+
+                brush_list = sc->vptr->pair_cdr (brush_list);
+                arg->default_value.sfa_brush.spacing =
+                  sc->vptr->ivalue (sc->vptr->pair_car (brush_list));
+
+                brush_list = sc->vptr->pair_cdr (brush_list);
+                arg->default_value.sfa_brush.paint_mode =
+                  sc->vptr->ivalue (sc->vptr->pair_car (brush_list));
+                #else
+                brush_list = sc->vptr->pair_car (a);
+                arg->default_value.sfa_brush =
+                  g_strdup (sc->vptr->string_value (sc->vptr->pair_car (brush_list)));
+                #endif
+              }
+              break;
+
+            case SF_GRADIENT:
+              if (!sc->vptr->is_string (sc->vptr->pair_car (a)))
+                return foreign_error (sc, "script-fu-register: gradient defaults must be string values", 0);
+
+              arg->default_value.sfa_gradient =
+                g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
+              break;
+
+            case SF_OPTION:
+              {
+                pointer option_list;
+
+                if (!sc->vptr->is_list (sc, a))
+                  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;
+                     option_list = sc->vptr->pair_cdr (option_list))
+                  {
+                    arg->default_value.sfa_option.list =
+                      g_slist_append (arg->default_value.sfa_option.list,
+                                      g_strdup (sc->vptr->string_value
+                                                (sc->vptr->pair_car (option_list))));
+                  }
+              }
+              break;
+
+            case SF_ENUM:
+              {
+                pointer      option_list;
+                const gchar *val;
+                gchar       *type_name;
+                GEnumValue  *enum_value;
+                GType        enum_type;
+
+                if (!sc->vptr->is_list (sc, a))
+                  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 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));
+
+                if (g_str_has_prefix (val, "Pika"))
+                  type_name = g_strdup (val);
+                else
+                  type_name = g_strconcat ("Pika", val, NULL);
+
+                enum_type = g_type_from_name (type_name);
+                if (! G_TYPE_IS_ENUM (enum_type))
+                  {
+                    g_free (type_name);
+                    return foreign_error (sc, "script-fu-register: first element in enum defaults must be the name of a registered type", 0);
+                  }
+
+                arg->default_value.sfa_enum.type_name = type_name;
+
+                option_list = sc->vptr->pair_cdr (option_list);
+                if (!sc->vptr->is_string (sc->vptr->pair_car (option_list)))
+                  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),
+                                            sc->vptr->string_value (sc->vptr->pair_car (option_list)));
+                if (enum_value)
+                  arg->default_value.sfa_enum.history = enum_value->value;
+              }
+              break;
+            }
+
+          a = sc->vptr->pair_cdr (a);
+        }
+      else
+        {
+          return foreign_error (sc, "script-fu-register: missing default argument", 0);
+        }
+    } /* end for */
+
+  /* Store local, advanced pointer at handle from caller. */
+  *handle = a;
+
+  return sc->NIL;
+}
+
+/* Traverse next arg in Scheme argument list.
+ * Set SFScript.drawable_arity from the argument.
+ * Used only by script-fu-register-filter.
+ *
+ * Return foreign_error or NIL.
+ */
+pointer
+script_fu_script_parse_drawable_arity_arg (scheme   *sc,
+                                           pointer  *handle,
+                                           SFScript *script)
+{
+  /* dereference handle into local pointer. */
+  pointer a = *handle;
+
+  /* argument must be an int, usually a symbol from enum e.g. SF-MULTIPLE-DRAWABLE */
+  if (!sc->vptr->is_integer (sc->vptr->pair_car (a)))
+    return foreign_error (sc, "script-fu-register-filter: drawable arity must be integer value", 0);
+  script->drawable_arity = sc->vptr->ivalue (sc->vptr->pair_car (a));
+
+  /* Advance the pointer into script. */
+  a = sc->vptr->pair_cdr (a);
+  *handle = a;
+  return sc->NIL;
+}

plug-ins/script-fu/libscriptfu/script-fu-register.h

@@ -0,0 +1,34 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_REGISTER_H__
+#define __SCRIPT_FU_REGISTER_H__
+
+pointer   script_fu_script_create_formal_args       (scheme   *sc,
+                                                     pointer  *handle,
+                                                     SFScript *script);
+SFScript *script_fu_script_new_from_metadata_args   (scheme   *sc,
+                                                     pointer  *handle);
+pointer   script_fu_script_parse_drawable_arity_arg (scheme   *sc,
+                                                     pointer  *handle,
+                                                     SFScript *script);
+
+#endif /* __SCRIPT_FU_REGISTER_H__ */

plug-ins/script-fu/libscriptfu/script-fu-run-func.c

@@ -0,0 +1,220 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <string.h>
+#include <glib.h>
+
+#include <libpika/pika.h>
+
+#include "scheme-wrapper.h"       /* type "pointer" */
+
+#include "script-fu-types.h"
+#include "script-fu-interface.h"  /* ScriptFu's GUI implementation. */
+#include "script-fu-dialog.h"     /* Pika's GUI implementation. */
+#include "script-fu-script.h"
+#include "script-fu-scripts.h"    /* script_fu_find_script */
+#include "script-fu-command.h"
+
+#include "script-fu-run-func.h"
+
+/* Outer run_funcs
+ * One each for PikaProcedure and PikaImageProcedure.
+ * These are called from Gimp, with two different signatures.
+ * These form and interpret "commands" which are calls to inner run_funcs
+ * defined in Scheme by a script.
+
+ * These return the result of interpretation,
+ * in a PikaValueArray whose only element is a status.
+ * !!! ScriptFu does not let authors define procedures that return values.
+ */
+
+/* run_func for a PikaImageProcedure
+ *
+ * Type is PikaRunImageFunc.
+ *
+ * Uses Pika's config and gui.
+ *
+ * Since 3.0
+ */
+PikaValueArray *
+script_fu_run_image_procedure ( PikaProcedure         *procedure, /* PikaImageProcedure */
+                                PikaRunMode           run_mode,
+                                PikaImage            *image,
+                                guint                 n_drawables,
+                                PikaDrawable        **drawables,
+                                const PikaValueArray *other_args,
+                                gpointer              data)
+{
+
+  PikaValueArray    *result = NULL;
+  SFScript          *script;
+
+  g_debug ("script_fu_run_image_procedure");
+  script = script_fu_find_script (pika_procedure_get_name (procedure));
+
+  if (! script)
+    return pika_procedure_new_return_values (procedure, PIKA_PDB_CALLING_ERROR, NULL);
+
+  ts_set_run_mode (run_mode);
+
+  switch (run_mode)
+    {
+    case PIKA_RUN_INTERACTIVE:
+      {
+        if (pika_value_array_length (other_args) > 0)
+          {
+            /* Let user choose "other" args in a dialog, then interpret. Maintain a config. */
+            result = script_fu_dialog_run (procedure, script, image, n_drawables, drawables, other_args);
+          }
+        else
+          {
+            /* No "other" args for user to choose. No config to maintain. */
+            result = script_fu_interpret_image_proc (procedure, script, image, n_drawables, drawables, other_args);
+          }
+        break;
+      }
+    case PIKA_RUN_NONINTERACTIVE:
+      {
+        /* A call from another PDB procedure.
+         * Use the given other_args, without interacting with user.
+         * Since no user interaction, no config to maintain.
+         */
+        result = script_fu_interpret_image_proc (procedure, script, image, n_drawables, drawables, other_args);
+        break;
+      }
+    case PIKA_RUN_WITH_LAST_VALS:
+      {
+        /* User invoked from a menu "Filter>Run with last values".
+         * Do not show dialog. other_args are already last values, from a config.
+         */
+        result = script_fu_interpret_image_proc (procedure, script, image, n_drawables, drawables, other_args);
+        break;
+      }
+    default:
+      {
+        result = pika_procedure_new_return_values (procedure, PIKA_PDB_CALLING_ERROR, NULL);
+      }
+    }
+  return result;
+}
+
+
+/* run_func for a PikaProcedure.
+ *
+ * Type is PikaRunFunc
+ *
+ * Uses ScriptFu's own GUI implementation, and retains settings locally.
+ *
+ * Since prior to 3.0 but formerly named script_fu_script_proc
+ */
+PikaValueArray *
+script_fu_run_procedure (PikaProcedure        *procedure,
+                         const PikaValueArray *args,
+                         gpointer              data)
+{
+  PikaPDBStatusType  status = PIKA_PDB_SUCCESS;
+  SFScript          *script;
+  PikaRunMode        run_mode;
+  GError            *error = NULL;
+
+  script = script_fu_find_script (pika_procedure_get_name (procedure));
+
+  if (! script)
+    return pika_procedure_new_return_values (procedure,
+                                             PIKA_PDB_CALLING_ERROR,
+                                             NULL);
+
+  run_mode = PIKA_VALUES_GET_ENUM (args, 0);
+
+  ts_set_run_mode (run_mode);
+
+  switch (run_mode)
+    {
+    case PIKA_RUN_INTERACTIVE:
+      {
+        gint min_args = 0;
+
+        /*  First, try to collect the standard script arguments...  */
+        min_args = script_fu_script_collect_standard_args (script, args);
+
+        /*  ...then acquire the rest of arguments (if any) with a dialog  */
+        if (script->n_args > min_args)
+          {
+            status = script_fu_interface (script, min_args);
+            break;
+          }
+        /*  otherwise (if the script takes no more arguments), skip
+         *  this part and run the script directly (fallthrough)
+         */
+      }
+
+    case PIKA_RUN_NONINTERACTIVE:
+      /*  Make sure all the arguments are there  */
+      if (pika_value_array_length (args) != (script->n_args + 1))
+        status = PIKA_PDB_CALLING_ERROR;
+
+      if (status == PIKA_PDB_SUCCESS)
+        {
+          gchar *command;
+
+          command = script_fu_script_get_command_from_params (script, args);
+
+          /*  run the command through the interpreter  */
+          if (! script_fu_run_command (command, &error))
+            {
+              return pika_procedure_new_return_values (procedure,
+                                                       PIKA_PDB_EXECUTION_ERROR,
+                                                       error);
+            }
+
+          g_free (command);
+        }
+      break;
+
+    case PIKA_RUN_WITH_LAST_VALS:
+      {
+        gchar *command;
+
+        /*  First, try to collect the standard script arguments  */
+        script_fu_script_collect_standard_args (script, args);
+
+        command = script_fu_script_get_command (script);
+
+        /*  run the command through the interpreter  */
+        if (! script_fu_run_command (command, &error))
+          {
+            return pika_procedure_new_return_values (procedure,
+                                                     PIKA_PDB_EXECUTION_ERROR,
+                                                     error);
+          }
+
+        g_free (command);
+      }
+      break;
+
+    default:
+      break;
+    }
+
+  return pika_procedure_new_return_values (procedure, status, NULL);
+}

plug-ins/script-fu/libscriptfu/script-fu-run-func.h

@@ -0,0 +1,37 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_RUN_FUNC_H__
+#define __SCRIPT_FU_RUN_FUNC_H__
+
+PikaValueArray *script_fu_run_procedure       (PikaProcedure        *procedure,
+                                               const PikaValueArray *args,
+                                               gpointer              data);
+
+PikaValueArray *script_fu_run_image_procedure (PikaProcedure        *procedure,
+                                               PikaRunMode           run_mode,
+                                               PikaImage            *image,
+                                               guint                 n_drawables,
+                                               PikaDrawable        **drawables,
+                                               const PikaValueArray *args,
+                                               gpointer              data);
+
+#endif /*  __SCRIPT_FU_RUN_FUNC__  */

plug-ins/script-fu/libscriptfu/script-fu-script.c

@@ -0,0 +1,626 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <string.h>
+
+#include <libpika/pika.h>
+
+#include "tinyscheme/scheme-private.h"
+
+#include "script-fu-types.h"
+#include "script-fu-arg.h"
+#include "script-fu-script.h"
+#include "script-fu-run-func.h"
+
+#include "script-fu-intl.h"
+
+
+/*
+ *  Local Functions
+ */
+
+static gboolean script_fu_script_param_init (SFScript             *script,
+                                             const PikaValueArray *args,
+                                             SFArgType             type,
+                                             gint                  n);
+static void     script_fu_script_set_proc_metadata (
+                                             PikaProcedure        *procedure,
+                                             SFScript             *script);
+static void     script_fu_script_set_proc_args (
+                                             PikaProcedure        *procedure,
+                                             SFScript             *script,
+                                             guint                 first_conveyed_arg);
+static void     script_fu_script_set_drawable_sensitivity (
+                                             PikaProcedure        *procedure,
+                                             SFScript             *script);
+
+static void     script_fu_command_append_drawables (
+                                             GString              *s,
+                                             guint                 n_drawables,
+                                             PikaDrawable        **drawables);
+/*
+ *  Function definitions
+ */
+
+SFScript *
+script_fu_script_new (const gchar *name,
+                      const gchar *menu_label,
+                      const gchar *blurb,
+                      const gchar *author,
+                      const gchar *copyright,
+                      const gchar *date,
+                      const gchar *image_types,
+                      gint         n_args)
+{
+  SFScript *script;
+
+  script = g_slice_new0 (SFScript);
+
+  script->name        = g_strdup (name);
+  script->menu_label  = g_strdup (menu_label);
+  script->blurb       = g_strdup (blurb);
+  script->author      = g_strdup (author);
+  script->copyright   = g_strdup (copyright);
+  script->date        = g_strdup (date);
+  script->image_types = g_strdup (image_types);
+
+  script->n_args = n_args;
+  script->args   = g_new0 (SFArg, script->n_args);
+
+  script->drawable_arity = SF_NO_DRAWABLE; /* default */
+
+  return script;
+}
+
+void
+script_fu_script_free (SFScript *script)
+{
+  gint i;
+
+  g_return_if_fail (script != NULL);
+
+  g_free (script->name);
+  g_free (script->blurb);
+  g_free (script->menu_label);
+  g_free (script->author);
+  g_free (script->copyright);
+  g_free (script->date);
+  g_free (script->image_types);
+
+  for (i = 0; i < script->n_args; i++)
+    {
+      script_fu_arg_free (&script->args[i]);
+    }
+
+  g_free (script->args);
+
+  g_slice_free (SFScript, script);
+}
+
+
+/*
+ * From the script, create a temporary PDB procedure,
+ * and install it as owned by the scriptfu extension PDB proc.
+ */
+void
+script_fu_script_install_proc (PikaPlugIn  *plug_in,
+                               SFScript    *script)
+{
+  PikaProcedure *procedure;
+
+  g_return_if_fail (PIKA_IS_PLUG_IN (plug_in));
+  g_return_if_fail (script != NULL);
+
+  procedure = script_fu_script_create_PDB_procedure (plug_in,
+                                                     script,
+                                                     PIKA_PDB_PROC_TYPE_TEMPORARY);
+
+  pika_plug_in_add_temp_procedure (plug_in, procedure);
+  g_object_unref (procedure);
+}
+
+
+/*
+ * Create and return a PikaProcedure or its subclass PikaImageProcedure.
+ * Caller typically either:
+ *    install it owned by self as TEMPORARY type procedure
+ *    OR return it as the result of a create_procedure callback from PIKA (PLUGIN type procedure.)
+ *
+ * Caller must unref the procedure.
+ *
+ * Understands ScriptFu's internal run funcs for PikaProcedure and PikaImageProcedure
+ */
+PikaProcedure *
+script_fu_script_create_PDB_procedure (PikaPlugIn     *plug_in,
+                                       SFScript       *script,
+                                       PikaPDBProcType plug_in_type)
+{
+  PikaProcedure *procedure;
+
+  if (script->proc_class == PIKA_TYPE_IMAGE_PROCEDURE)
+    {
+      g_debug ("script_fu_script_create_PDB_procedure: %s, plugin type %i, image_proc",
+               script->name, plug_in_type);
+
+      procedure = pika_image_procedure_new (
+                                      plug_in, script->name,
+                                      plug_in_type,
+                                      (PikaRunImageFunc) script_fu_run_image_procedure,
+                                      script, /* user_data, pointer in extension-script-fu process */
+                                      NULL);
+
+      script_fu_script_set_proc_metadata (procedure, script);
+
+      /* Script author does not declare image, drawable in script-fu-register-filter,
+       * and we don't add to formal args in PDB.
+       * The convenience class PikaImageProcedure already has formal args:
+       * run_mode, image, n_drawables, drawables.
+       * "0" means not skip any arguments declared in the script.
+       */
+      script_fu_script_set_proc_args (procedure, script, 0);
+
+      script_fu_script_set_drawable_sensitivity (procedure, script);
+    }
+  else
+    {
+      g_assert (script->proc_class == PIKA_TYPE_PROCEDURE);
+      g_debug ("script_fu_script_create_PDB_procedure: %s, plugin type %i, ordinary proc",
+               script->name, plug_in_type);
+
+      procedure = pika_procedure_new (plug_in, script->name,
+                                      plug_in_type,
+                                      script_fu_run_procedure,
+                                      script, NULL);
+
+      script_fu_script_set_proc_metadata (procedure, script);
+
+      pika_procedure_add_argument (procedure,
+                                   g_param_spec_enum ("run-mode",
+                                                      "Run mode",
+                                                      "The run mode",
+                                                      PIKA_TYPE_RUN_MODE,
+                                                      PIKA_RUN_INTERACTIVE,
+                                                      G_PARAM_READWRITE));
+
+      script_fu_script_set_proc_args (procedure, script, 0);
+
+      /* !!! Author did not declare drawable arity, it was inferred. */
+      script_fu_script_set_drawable_sensitivity (procedure, script);
+    }
+
+
+  return procedure;
+}
+
+void
+script_fu_script_uninstall_proc (PikaPlugIn *plug_in,
+                                 SFScript   *script)
+{
+  g_return_if_fail (PIKA_IS_PLUG_IN (plug_in));
+  g_return_if_fail (script != NULL);
+
+  pika_plug_in_remove_temp_procedure (plug_in, script->name);
+}
+
+gchar *
+script_fu_script_get_title (SFScript *script)
+{
+  gchar *title;
+  gchar *tmp;
+
+  g_return_val_if_fail (script != NULL, NULL);
+
+  /* strip mnemonics from the menupath */
+  title = pika_strip_uline (script->menu_label);
+
+  /* if this looks like a full menu path, use only the last part */
+  if (title[0] == '<' && (tmp = strrchr (title, '/')) && tmp[1])
+    {
+      tmp = g_strdup (tmp + 1);
+
+      g_free (title);
+      title = tmp;
+    }
+
+  /* cut off ellipsis */
+  tmp = (strstr (title, "..."));
+  if (! tmp)
+    /* U+2026 HORIZONTAL ELLIPSIS */
+    tmp = strstr (title, "\342\200\246");
+
+  if (tmp && tmp == (title + strlen (title) - 3))
+    *tmp = '\0';
+
+  return title;
+}
+
+void
+script_fu_script_reset (SFScript *script,
+                        gboolean  reset_ids)
+{
+  gint i;
+
+  g_return_if_fail (script != NULL);
+
+  for (i = 0; i < script->n_args; i++)
+    {
+      script_fu_arg_reset (&script->args[i], reset_ids);
+    }
+}
+
+gint
+script_fu_script_collect_standard_args (SFScript             *script,
+                                        const PikaValueArray *args)
+{
+  gint params_consumed = 0;
+
+  g_return_val_if_fail (script != NULL, 0);
+
+  /*  the first parameter may be a DISPLAY id  */
+  if (script_fu_script_param_init (script,
+                                   args, SF_DISPLAY,
+                                   params_consumed))
+    {
+      params_consumed++;
+    }
+
+  /*  an IMAGE id may come first or after the DISPLAY id  */
+  if (script_fu_script_param_init (script,
+                                   args, SF_IMAGE,
+                                   params_consumed))
+    {
+      params_consumed++;
+
+      /*  and may be followed by a DRAWABLE, LAYER, CHANNEL or
+       *  VECTORS id
+       */
+      if (script_fu_script_param_init (script,
+                                       args, SF_DRAWABLE,
+                                       params_consumed) ||
+          script_fu_script_param_init (script,
+                                       args, SF_LAYER,
+                                       params_consumed) ||
+          script_fu_script_param_init (script,
+                                       args, SF_CHANNEL,
+                                       params_consumed) ||
+          script_fu_script_param_init (script,
+                                       args, SF_VECTORS,
+                                       params_consumed))
+        {
+          params_consumed++;
+        }
+    }
+
+  return params_consumed;
+}
+
+/* Methods that form "commands" i.e. texts in Scheme language
+ * that represent calls to the inner run func defined in a script.
+ */
+
+gchar *
+script_fu_script_get_command (SFScript *script)
+{
+  GString *s;
+  gint     i;
+
+  g_return_val_if_fail (script != NULL, NULL);
+
+  s = g_string_new ("(");
+  g_string_append (s, script->name);
+
+  for (i = 0; i < script->n_args; i++)
+    {
+      g_string_append_c (s, ' ');
+
+      script_fu_arg_append_repr_from_self (&script->args[i], s);
+    }
+
+  g_string_append_c (s, ')');
+
+  return g_string_free (s, FALSE);
+}
+
+gchar *
+script_fu_script_get_command_from_params (SFScript             *script,
+                                          const PikaValueArray *args)
+{
+  GString *s;
+  gint     i;
+
+  g_return_val_if_fail (script != NULL, NULL);
+
+  s = g_string_new ("(");
+  g_string_append (s, script->name);
+
+  for (i = 0; i < script->n_args; i++)
+    {
+      GValue *value = pika_value_array_index (args, i + 1);
+
+      g_string_append_c (s, ' ');
+
+      script_fu_arg_append_repr_from_gvalue (&script->args[i],
+                                             s,
+                                             value);
+    }
+
+  g_string_append_c (s, ')');
+
+  return g_string_free (s, FALSE);
+}
+
+/* Append a literal representing a Scheme container of numerics
+ * where the numerics are the ID's of the given drawables.
+ * Container is scheme vector, meaning its elements are all the same type.
+ */
+static void
+script_fu_command_append_drawables (GString       *s,
+                                    guint          n_drawables,
+                                    PikaDrawable **drawables)
+{
+  /* Require non-empty array of drawables. */
+  g_assert (n_drawables > 0);
+
+  /* !!! leading space to separate from prior args.
+   * #() is scheme syntax for a vector.
+   */
+  g_string_append (s, " #(" );
+  for (guint i=0; i < n_drawables; i++)
+    {
+      g_string_append_printf (s, " %d", pika_item_get_id ((PikaItem*) drawables[i]));
+    }
+  g_string_append (s, ")" );
+  /* Ensure string is like: " #( 1 2 3)" */
+}
+
+
+gchar *
+script_fu_script_get_command_for_image_proc (SFScript            *script,
+                                             PikaImage            *image,
+                                             guint                 n_drawables,
+                                             PikaDrawable        **drawables,
+                                             const PikaValueArray *args)
+{
+  GString *s;
+
+  g_return_val_if_fail (script != NULL, NULL);
+
+  s = g_string_new ("(");
+  g_string_append (s, script->name);
+
+  /* The command has no run mode. */
+
+  /* scripts use integer ID's for Pika objects. */
+  g_string_append_printf (s, " %d", pika_image_get_id (image));
+
+  /* Not pass n_drawables.
+   * An author must use Scheme functions for length of container of drawables.
+   */
+
+  /* Append text repr for a container of all drawable ID's.
+   * Even if script->drawable_arity = SF_PROC_IMAGE_SINGLE_DRAWABLE
+   * since that means the inner run func takes many but will only process one.
+   * We are not adapting to an inner run func that expects a single numeric.
+   */
+  script_fu_command_append_drawables (s, n_drawables, drawables);
+
+  /* args contains the "other" args
+   * Iterate over the PikaValueArray.
+   * But script->args should be the same length, and types should match.
+   */
+  for (guint i = 0; i < pika_value_array_length (args); i++)
+    {
+      GValue *value = pika_value_array_index (args, i);
+      g_string_append_c (s, ' ');
+      script_fu_arg_append_repr_from_gvalue (&script->args[i],
+                                             s,
+                                             value);
+    }
+
+  g_string_append_c (s, ')');
+
+  return g_string_free (s, FALSE);
+}
+
+/* Infer whether the script, defined using v2 script-fu-register,
+ * which does not specify the arity for drawables,
+ * is actually a script that takes one and only one drawable.
+ * Such plugins are deprecated in v3: each plugin must take container of drawables
+ * and declare its drawable arity via pika_procedure_set_sensitivity_mask.
+ */
+void
+script_fu_script_infer_drawable_arity (SFScript *script)
+{
+  if ((script->n_args > 1) &&
+      script->args[0].type == SF_IMAGE &&
+      script->args[1].type == SF_DRAWABLE)
+    {
+      g_debug ("Inferring drawable arity one.");
+      script->drawable_arity = SF_ONE_DRAWABLE;
+    }
+}
+
+/*
+ *  Local Functions
+ */
+
+static gboolean
+script_fu_script_param_init (SFScript             *script,
+                             const PikaValueArray *args,
+                             SFArgType             type,
+                             gint                  n)
+{
+  SFArg *arg = &script->args[n];
+
+  if (script->n_args > n &&
+      arg->type == type  &&
+      pika_value_array_length (args) > n + 1)
+    {
+      GValue *value = pika_value_array_index (args, n + 1);
+
+      switch (type)
+        {
+        case SF_IMAGE:
+          if (PIKA_VALUE_HOLDS_IMAGE (value))
+            {
+              PikaImage *image = g_value_get_object (value);
+
+              arg->value.sfa_image = pika_image_get_id (image);
+              return TRUE;
+            }
+          break;
+
+        case SF_DRAWABLE:
+          if (PIKA_VALUE_HOLDS_DRAWABLE (value))
+            {
+              PikaItem *item = g_value_get_object (value);
+
+              arg->value.sfa_drawable = pika_item_get_id (item);
+              return TRUE;
+            }
+          break;
+
+        case SF_LAYER:
+          if (PIKA_VALUE_HOLDS_LAYER (value))
+            {
+              PikaItem *item = g_value_get_object (value);
+
+              arg->value.sfa_layer = pika_item_get_id (item);
+              return TRUE;
+            }
+          break;
+
+        case SF_CHANNEL:
+          if (PIKA_VALUE_HOLDS_CHANNEL (value))
+            {
+              PikaItem *item = g_value_get_object (value);
+
+              arg->value.sfa_channel = pika_item_get_id (item);
+              return TRUE;
+            }
+          break;
+
+        case SF_VECTORS:
+          if (PIKA_VALUE_HOLDS_VECTORS (value))
+            {
+              PikaItem *item = g_value_get_object (value);
+
+              arg->value.sfa_vectors = pika_item_get_id (item);
+              return TRUE;
+            }
+          break;
+
+        case SF_DISPLAY:
+          if (PIKA_VALUE_HOLDS_DISPLAY (value))
+            {
+              PikaDisplay *display = g_value_get_object (value);
+
+              arg->value.sfa_display = pika_display_get_id (display);
+              return TRUE;
+            }
+          break;
+
+        default:
+          break;
+        }
+    }
+
+  return FALSE;
+}
+
+
+static void
+script_fu_script_set_proc_metadata (PikaProcedure *procedure,
+                                    SFScript      *script)
+{
+  const gchar *menu_label = NULL;
+
+  /* Allow scripts with no menus */
+  if (strncmp (script->menu_label, "<None>", 6) != 0)
+    menu_label = script->menu_label;
+
+  pika_procedure_set_image_types (procedure, script->image_types);
+
+  if (menu_label && strlen (menu_label))
+    pika_procedure_set_menu_label (procedure, menu_label);
+
+  pika_procedure_set_documentation (procedure,
+                                    script->blurb,
+                                    NULL,
+                                    script->name);
+  pika_procedure_set_attribution (procedure,
+                                  script->author,
+                                  script->copyright,
+                                  script->date);
+}
+
+/* Convey formal arguments from SFArg to the PDB. */
+static void
+script_fu_script_set_proc_args (PikaProcedure *procedure,
+                                SFScript      *script,
+                                guint          first_conveyed_arg)
+{
+  script_fu_arg_reset_name_generator ();
+  for (gint i = first_conveyed_arg; i < script->n_args; i++)
+    {
+      GParamSpec  *pspec = NULL;
+      const gchar *name  = NULL;
+      const gchar *nick  = NULL;
+
+      script_fu_arg_generate_name_and_nick (&script->args[i], &name, &nick);
+      pspec = script_fu_arg_get_param_spec (&script->args[i],
+                                            name,
+                                            nick);
+      pika_procedure_add_argument (procedure, pspec);
+    }
+}
+
+/* Convey drawable arity to the PDB.
+ * !!! Unless set, sensitivity defaults to drawable arity 1.
+ * See libpika/pikaprocedure.c pika_procedure_set_sensitivity_mask
+ */
+static void
+script_fu_script_set_drawable_sensitivity (PikaProcedure *procedure, SFScript *script)
+{
+  switch (script->drawable_arity)
+    {
+    case SF_TWO_OR_MORE_DRAWABLE:
+      pika_procedure_set_sensitivity_mask (procedure,
+                                           PIKA_PROCEDURE_SENSITIVE_DRAWABLES);
+      break;
+    case SF_ONE_OR_MORE_DRAWABLE:
+      pika_procedure_set_sensitivity_mask (procedure,
+                                           PIKA_PROCEDURE_SENSITIVE_DRAWABLE |
+                                           PIKA_PROCEDURE_SENSITIVE_DRAWABLES);
+      break;
+    case SF_ONE_DRAWABLE:
+      pika_procedure_set_sensitivity_mask (procedure, PIKA_PROCEDURE_SENSITIVE_DRAWABLE);
+      break;
+    case SF_NO_DRAWABLE:
+      /* menu item always sensitive. */
+      break;
+    default:
+      /* Fail to set sensitivy mask. */
+      g_warning ("Unhandled case for SFDrawableArity");
+    }
+}

plug-ins/script-fu/libscriptfu/script-fu-script.h

@@ -0,0 +1,64 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_SCRIPT_H__
+#define __SCRIPT_FU_SCRIPT_H__
+
+
+SFScript * script_fu_script_new                     (const gchar          *name,
+                                                     const gchar          *menu_label,
+                                                     const gchar          *blurb,
+                                                     const gchar          *authors,
+                                                     const gchar          *copyright,
+                                                     const gchar          *date,
+                                                     const gchar          *image_types,
+                                                     gint                  n_args);
+void       script_fu_script_free                    (SFScript             *script);
+
+void       script_fu_script_install_proc            (PikaPlugIn           *plug_in,
+                                                     SFScript             *script);
+void       script_fu_script_uninstall_proc          (PikaPlugIn           *plug_in,
+                                                     SFScript             *script);
+
+gchar    * script_fu_script_get_title               (SFScript             *script);
+void       script_fu_script_reset                   (SFScript             *script,
+                                                     gboolean              reset_ids);
+
+gint       script_fu_script_collect_standard_args   (SFScript             *script,
+                                                     const PikaValueArray *args);
+
+gchar    * script_fu_script_get_command             (SFScript             *script);
+gchar    * script_fu_script_get_command_from_params (SFScript             *script,
+                                                     const PikaValueArray *args);
+gchar    * script_fu_script_get_command_for_image_proc (
+                                                     SFScript             *script,
+                                                     PikaImage            *image,
+                                                     guint                 n_drawables,
+                                                     PikaDrawable        **drawables,
+                                                     const PikaValueArray *args);
+
+PikaProcedure * script_fu_script_create_PDB_procedure (PikaPlugIn         *plug_in,
+                                                       SFScript           *script,
+                                                       PikaPDBProcType     plug_in_type);
+
+void            script_fu_script_infer_drawable_arity (SFScript           *script);
+
+#endif /*  __SCRIPT_FU_SCRIPT__  */

plug-ins/script-fu/libscriptfu/script-fu-scripts.c

@@ -0,0 +1,617 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <string.h>
+#include <glib.h>
+
+#ifdef G_OS_WIN32
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#endif
+
+#include <libpika/pika.h>
+
+#include "tinyscheme/scheme-private.h"
+
+#include "script-fu-types.h"
+#include "script-fu-script.h"
+#include "script-fu-scripts.h"
+#include "script-fu-utils.h"
+#include "script-fu-register.h"
+#include "script-fu-command.h"
+
+#include "script-fu-intl.h"
+
+
+/*
+ *  Local Functions
+ */
+
+static void             script_fu_load_directory (GFile                *directory);
+static void             script_fu_load_script    (GFile                *file);
+static gboolean         script_fu_install_script (gpointer              foo,
+                                                  GList                *scripts,
+                                                  gpointer              data);
+static void             script_fu_install_menu   (SFMenu               *menu);
+static gboolean         script_fu_remove_script  (gpointer              foo,
+                                                  GList                *scripts,
+                                                  gpointer              data);
+
+static gchar          * script_fu_menu_map       (const gchar          *menu_path);
+static gint             script_fu_menu_compare   (gconstpointer         a,
+                                                  gconstpointer         b);
+
+static void             script_fu_try_map_menu           (SFScript     *script);
+static void             script_fu_append_script_to_tree  (SFScript     *script);
+
+/*
+ *  Local variables
+ */
+
+static GTree *script_tree      = NULL;
+static GList *script_menu_list = NULL;
+
+
+/*
+ *  Function definitions
+ */
+
+/* Traverse list of paths, finding .scm files.
+ * Load and eval any found script texts.
+ * Script texts will call Scheme functions script-fu-register
+ * and script-fu-menu-register,
+ * which insert a SFScript record into script_tree,
+ * and insert a SFMenu record into script_menu_list.
+ * These are side effects on the state of the outer (SF) interpreter.
+ *
+ * Return the tree of scripts, as well as keeping a local pointer to the tree.
+ * The other result (script_menu_list) is not returned, see script_fu_get_menu_list.
+ *
+ * Caller should free script_tree and script_menu_list,
+ * This should only be called once.
+ */
+GTree *
+script_fu_find_scripts_into_tree ( PikaPlugIn *plug_in,
+                                   GList      *paths)
+{
+  /*  Clear any existing scripts  */
+  if (script_tree != NULL)
+    {
+      g_tree_foreach (script_tree,
+                      (GTraverseFunc) script_fu_remove_script,
+                      plug_in);
+      g_tree_destroy (script_tree);
+    }
+
+  script_tree = g_tree_new ((GCompareFunc) g_utf8_collate);
+
+  if (paths)
+    {
+      GList *list;
+
+      for (list = paths; list; list = g_list_next (list))
+        {
+          script_fu_load_directory (list->data);
+        }
+    }
+
+  /*
+   * Assert result is not NULL, but may be an empty tree.
+   * When paths is NULL, or no scripts found at paths.
+   */
+
+  g_debug ("script_fu_find_scripts_into_tree found %i scripts", g_tree_nnodes (script_tree));
+  return script_tree;
+}
+
+/*
+ * Return list of SFMenu for recently loaded scripts.
+ * List is non-empty only after a call to script_fu_find_scripts_into_tree.
+ */
+GList *
+script_fu_get_menu_list (void)
+{
+  return script_menu_list;
+}
+
+/* Find scripts, create and install TEMPORARY PDB procedures,
+ * owned by self PDB procedure (e.g. extension-script-fu.)
+ */
+void
+script_fu_find_scripts (PikaPlugIn *plug_in,
+                        GList      *path)
+{
+  script_fu_find_scripts_into_tree (plug_in, path);
+
+  /*  Now that all scripts are read in and sorted, tell pika about them  */
+  g_tree_foreach (script_tree,
+                  (GTraverseFunc) script_fu_install_script,
+                  plug_in);
+
+  script_menu_list = g_list_sort (script_menu_list,
+                                  (GCompareFunc) script_fu_menu_compare);
+
+  /*  Install and nuke the list of menu entries  */
+  g_list_free_full (script_menu_list,
+                    (GDestroyNotify) script_fu_install_menu);
+  script_menu_list = NULL;
+}
+
+
+
+/* For a script's call to script-fu-register.
+ * Traverse Scheme argument list creating a new SFScript
+ * whose drawable_arity is SF_PROC_ORDINARY.
+ *
+ * Return NIL or a foreign_error
+ */
+pointer
+script_fu_add_script (scheme  *sc,
+                      pointer  a)
+{
+  SFScript    *script;
+  pointer      args_error;
+
+  /*  Check metadata args args are present */
+  if (sc->vptr->list_length (sc, a) < 7)
+    return foreign_error (sc, "script-fu-register: Not enough arguments", 0);
+
+  /* pass handle to pointer into script (on the stack) */
+  script = script_fu_script_new_from_metadata_args (sc, &a);
+
+  /* Require drawable_arity defaults to SF_PROC_ORDINARY.
+   * script-fu-register specifies an ordinary PikaProcedure.
+   * We may go on to infer a different arity.
+   */
+  g_assert (script->drawable_arity == SF_NO_DRAWABLE);
+
+  args_error = script_fu_script_create_formal_args (sc, &a, script);
+  if (args_error != sc->NIL)
+    return args_error;
+
+  /*  fill all values from defaults  */
+  script_fu_script_reset (script, TRUE);
+
+  /* Infer whether the script really requires one drawable,
+   * so that later we can set the sensitivity.
+   * For backward compatibility:
+   * v2 script-fu-register does not require author to declare drawable arity.
+   */
+  script_fu_script_infer_drawable_arity (script);
+
+  script->proc_class = PIKA_TYPE_PROCEDURE;
+
+  script_fu_try_map_menu (script);
+  script_fu_append_script_to_tree (script);
+  return sc->NIL;
+}
+
+/* For a script's call to script-fu-register-filter.
+ * Traverse Scheme argument list creating a new SFScript
+ * whose drawable_arity is SF_PROC_IMAGE_MULTIPLE_DRAWABLE or
+ * SF_PROC_IMAGE_SINGLE_DRAWABLE
+ *
+ * Same as script-fu-register, except one more arg for drawable_arity.
+ *
+ * Return NIL or a foreign_error
+ */
+pointer
+script_fu_add_script_filter (scheme  *sc,
+                             pointer  a)
+{
+  SFScript    *script;
+  pointer      args_error;  /* a foreign_error or NIL. */
+
+  /* Check metadata args args are present.
+   * Has one more arg than script-fu-register.
+   */
+  if (sc->vptr->list_length (sc, a) < 8)
+    return foreign_error (sc, "script-fu-register-filter: Not enough arguments", 0);
+
+  /* pass handle i.e. "&a" ("a" of type "pointer" is on the stack) */
+  script = script_fu_script_new_from_metadata_args (sc, &a);
+
+  /* Check semantic error: a script declaring it takes an image must specify
+   * image types.  Otherwise the script's menu item will be enabled
+   * even when no images exist.
+   */
+  if (g_strcmp0(script->image_types, "")==0)
+    return foreign_error (sc, "script-fu-register-filter: A filter must declare image types.", 0);
+
+  args_error = script_fu_script_parse_drawable_arity_arg (sc, &a, script);
+  if (args_error != sc->NIL)
+      return args_error;
+
+  args_error = script_fu_script_create_formal_args (sc, &a, script);
+  if (args_error != sc->NIL)
+      return args_error;
+
+  script->proc_class = PIKA_TYPE_IMAGE_PROCEDURE;
+
+  script_fu_try_map_menu (script);
+  script_fu_append_script_to_tree (script);
+  return sc->NIL;
+}
+
+pointer
+script_fu_add_menu (scheme  *sc,
+                    pointer  a)
+{
+  SFScript    *script;
+  SFMenu      *menu;
+  const gchar *name;
+  const gchar *path;
+
+  /*  Check the length of a  */
+  if (sc->vptr->list_length (sc, a) != 2)
+    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));
+  a = sc->vptr->pair_cdr (a);
+
+  script = script_fu_find_script (name);
+
+  if (! script)
+    {
+      g_message ("Procedure %s in script-fu-menu-register does not exist",
+                 name);
+      return sc->NIL;
+    }
+
+  /*  Create a new list of menus  */
+  menu = g_slice_new0 (SFMenu);
+
+  menu->script = script;
+
+  /*  Find the script menu path  */
+  path = sc->vptr->string_value (sc->vptr->pair_car (a));
+
+  menu->menu_path = script_fu_menu_map (path);
+
+  if (! menu->menu_path)
+    menu->menu_path = g_strdup (path);
+
+  script_menu_list = g_list_prepend (script_menu_list, menu);
+
+  return sc->NIL;
+}
+
+
+/*  private functions  */
+
+static void
+script_fu_load_directory (GFile *directory)
+{
+  GFileEnumerator *enumerator;
+
+  g_debug ("Load dir: %s", g_file_get_parse_name (directory));
+
+  enumerator = g_file_enumerate_children (directory,
+                                          G_FILE_ATTRIBUTE_STANDARD_NAME ","
+                                          G_FILE_ATTRIBUTE_STANDARD_IS_HIDDEN ","
+                                          G_FILE_ATTRIBUTE_STANDARD_TYPE,
+                                          G_FILE_QUERY_INFO_NONE,
+                                          NULL, NULL);
+
+  if (enumerator)
+    {
+      GFileInfo *info;
+
+      while ((info = g_file_enumerator_next_file (enumerator, NULL, NULL)))
+        {
+          GFileType file_type = g_file_info_get_file_type (info);
+
+          if ((file_type == G_FILE_TYPE_REGULAR ||
+               file_type == G_FILE_TYPE_DIRECTORY) &&
+              ! g_file_info_get_is_hidden (info))
+            {
+              GFile *child = g_file_enumerator_get_child (enumerator, info);
+
+              if (file_type == G_FILE_TYPE_DIRECTORY)
+                script_fu_load_directory (child);
+              else
+                script_fu_load_script (child);
+
+              g_object_unref (child);
+            }
+
+          g_object_unref (info);
+        }
+
+      g_object_unref (enumerator);
+    }
+}
+
+static void
+script_fu_load_script (GFile *file)
+{
+  if (pika_file_has_extension (file, ".scm"))
+    {
+      gchar  *path    = g_file_get_path (file);
+      gchar  *escaped = script_fu_strescape (path);
+      gchar  *command;
+      GError *error   = NULL;
+
+      command = g_strdup_printf ("(load \"%s\")", escaped);
+      g_free (escaped);
+
+      if (! script_fu_run_command (command, &error))
+        {
+          gchar *message = g_strdup_printf (_("Error while loading %s:"),
+                                            pika_file_get_utf8_name (file));
+
+          g_message ("%s\n\n%s", message, error->message);
+
+          g_clear_error (&error);
+          g_free (message);
+        }
+
+#ifdef G_OS_WIN32
+      /* No, I don't know why, but this is
+       * necessary on NT 4.0.
+       */
+      Sleep (0);
+#endif
+
+      g_free (command);
+      g_free (path);
+    }
+}
+
+/* This is-a GTraverseFunction.
+ *
+ * Traverse.  For each, install TEMPORARY PDB proc.
+ * Returning FALSE means entire list was traversed.
+ */
+static gboolean
+script_fu_install_script (gpointer  foo G_GNUC_UNUSED,
+                          GList    *scripts,
+                          gpointer  data)
+{
+  PikaPlugIn *plug_in = data;
+  GList      *list;
+
+  for (list = scripts; list; list = g_list_next (list))
+    {
+      SFScript *script = list->data;
+
+      const gchar* name = script->name;
+      if (script_fu_is_defined (name))
+        script_fu_script_install_proc (plug_in, script);
+      else
+        g_warning ("Run function not defined, or does not match PDB procedure name: %s", name);
+    }
+
+  return FALSE;
+}
+
+static void
+script_fu_install_menu (SFMenu *menu)
+{
+  PikaPlugIn    *plug_in   = pika_get_plug_in ();
+  PikaProcedure *procedure = NULL;
+
+  procedure = pika_plug_in_get_temp_procedure (plug_in,
+                                               menu->script->name);
+
+  if (procedure)
+    pika_procedure_add_menu_path (procedure, menu->menu_path);
+
+  g_free (menu->menu_path);
+  g_slice_free (SFMenu, menu);
+}
+
+/*
+ *  The following function is a GTraverseFunction.
+ */
+static gboolean
+script_fu_remove_script (gpointer  foo G_GNUC_UNUSED,
+                         GList    *scripts,
+                         gpointer  data)
+{
+  PikaPlugIn *plug_in = data;
+  GList      *list;
+
+  for (list = scripts; list; list = g_list_next (list))
+    {
+      SFScript *script = list->data;
+
+      script_fu_script_uninstall_proc (plug_in, script);
+      script_fu_script_free (script);
+    }
+
+  g_list_free (scripts);
+
+  return FALSE;
+}
+
+
+
+/* this is a GTraverseFunction */
+static gboolean
+script_fu_lookup_script (gpointer      *foo G_GNUC_UNUSED,
+                         GList         *scripts,
+                         gconstpointer *name)
+{
+  GList *list;
+
+  for (list = scripts; list; list = g_list_next (list))
+    {
+      SFScript *script = list->data;
+
+      if (strcmp (script->name, *name) == 0)
+        {
+          /* store the script in the name pointer and stop the traversal */
+          *name = script;
+          return TRUE;
+        }
+    }
+
+  return FALSE;
+}
+
+SFScript *
+script_fu_find_script (const gchar *name)
+{
+  gconstpointer script = name;
+
+  g_tree_foreach (script_tree,
+                  (GTraverseFunc) script_fu_lookup_script,
+                  &script);
+
+  if (script == name)
+    return NULL;
+
+  return (SFScript *) script;
+}
+
+static gchar *
+script_fu_menu_map (const gchar *menu_path)
+{
+  /*  for backward compatibility, we fiddle with some menu paths  */
+  const struct
+  {
+    const gchar *old;
+    const gchar *new;
+  } mapping[] = {
+    { "<Image>/Script-Fu/Alchemy",       "<Image>/Filters/Artistic"            },
+    { "<Image>/Script-Fu/Alpha to Logo", "<Image>/Filters/Alpha to Logo"       },
+    { "<Image>/Script-Fu/Animators",     "<Image>/Filters/Animation" },
+    { "<Image>/Script-Fu/Decor",         "<Image>/Filters/Decor"               },
+    { "<Image>/Script-Fu/Render",        "<Image>/Filters/Render"              },
+    { "<Image>/Script-Fu/Selection",     "<Image>/Select/Modify"               },
+    { "<Image>/Script-Fu/Shadow",        "<Image>/Filters/Light and Shadow/[Shadow]" },
+    { "<Image>/Script-Fu/Stencil Ops",   "<Image>/Filters/Decor"               }
+  };
+
+  gint i;
+
+  for (i = 0; i < G_N_ELEMENTS (mapping); i++)
+    {
+      if (g_str_has_prefix (menu_path, mapping[i].old))
+        {
+          const gchar *suffix = menu_path + strlen (mapping[i].old);
+
+          if (*suffix != '/')
+            continue;
+
+          return g_strconcat (mapping[i].new, suffix, NULL);
+        }
+    }
+
+  return NULL;
+}
+
+static gint
+script_fu_menu_compare (gconstpointer a,
+                        gconstpointer b)
+{
+  const SFMenu *menu_a = a;
+  const SFMenu *menu_b = b;
+  gint          retval = 0;
+
+  if (menu_a->menu_path && menu_b->menu_path)
+    {
+      retval = g_utf8_collate (menu_a->menu_path,
+                               menu_b->menu_path);
+
+      if (retval == 0 &&
+          menu_a->script->menu_label && menu_b->script->menu_label)
+        {
+          retval = g_utf8_collate (menu_a->script->menu_label,
+                                   menu_b->script->menu_label);
+        }
+    }
+
+  return retval;
+}
+
+/* Is name a defined symbol in the interpreter state?
+ * (Defined in any script already loaded.)
+ * Where "symbol" has the usual lisp meaning: a unique name associated with
+ * a variable or function.
+ *
+ * The most common use is
+ * test the name of a PDB proc, which in ScriptFu must match
+ * a defined function that is the inner run function.
+ * I.E. check for typos by author of script.
+ * Used during query, to preflight so that we don't install a PDB proc
+ * that won't run later (during the run phase)
+ * giving "undefined symbol" for extension-script-fu.
+ * Note that if instead we create a PDB proc having no defined run func,
+ * script-fu-interpreter would load and define a same-named scheme function
+ * that calls the PDB, and can enter an infinite loop.
+ */
+gboolean
+script_fu_is_defined (const gchar * name)
+{
+  gchar   *scheme_text;
+  GError  *error = NULL;
+  gboolean result;
+
+  /* text to be interpreted is a call to an internal scheme function. */
+  scheme_text = g_strdup_printf (" (symbol? %s ) ",  name);
+
+  /* Use script_fu_run_command, it correctly handles the string yielded.
+   * But we don't need the string yielded.
+   * If defined, string yielded is "#t", else is "Undefined symbol" or "#f"
+   */
+  result = script_fu_run_command (scheme_text, &error);
+  if (!result)
+    {
+      g_debug ("script_fu_is_defined returns false");
+      /* error contains string yielded by interpretation. */
+      g_error_free (error);
+    }
+  return result;
+}
+
+
+/* Side effects on script. */
+static void
+script_fu_try_map_menu (SFScript *script)
+{
+  if (script->menu_label[0] == '<')
+    {
+      gchar *mapped = script_fu_menu_map (script->menu_label);
+
+      if (mapped)
+        {
+          g_free (script->menu_label);
+          script->menu_label = mapped;
+        }
+    }
+}
+
+/* Append to ordered tree.
+ * Side effects on script_tree.
+ */
+static void
+script_fu_append_script_to_tree (SFScript *script)
+{
+  GList *list = g_tree_lookup (script_tree, script->menu_label);
+
+  g_tree_insert (script_tree, (gpointer) script->menu_label,
+                  g_list_append (list, script));
+}

plug-ins/script-fu/libscriptfu/script-fu-scripts.h

@@ -0,0 +1,41 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_SCRIPTS_H__
+#define __SCRIPT_FU_SCRIPTS_H__
+
+void      script_fu_find_scripts  (PikaPlugIn *plug_in,
+                                   GList      *path);
+pointer   script_fu_add_script        (scheme     *sc,
+                                       pointer     a);
+pointer   script_fu_add_script_filter (scheme     *sc,
+                                       pointer     a);
+pointer   script_fu_add_menu      (scheme     *sc,
+                                   pointer     a);
+
+GTree          * script_fu_find_scripts_into_tree (PikaPlugIn  *plug_in,
+                                                   GList       *path);
+SFScript       * script_fu_find_script            (const gchar *name);
+GList          * script_fu_get_menu_list          (void);
+
+gboolean         script_fu_is_defined             (const gchar          *name);
+
+#endif /*  __SCRIPT_FU_SCRIPTS__  */

plug-ins/script-fu/libscriptfu/script-fu-types.h

@@ -0,0 +1,109 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_TYPES_H__
+#define __SCRIPT_FU_TYPES_H__
+
+
+#include "script-fu-enums.h"
+
+
+typedef struct
+{
+  gdouble           value;
+  gdouble           lower;
+  gdouble           upper;
+  gdouble           step;
+  gdouble           page;
+  gint              digits;
+  SFAdjustmentType  type;
+} SFAdjustment;
+
+typedef struct
+{
+  gchar  *filename;
+} SFFilename;
+
+typedef struct
+{
+  GSList *list;
+  gint    history;
+} SFOption;
+
+typedef struct
+{
+  gchar *type_name;
+  gint   history;
+} SFEnum;
+
+typedef union
+{
+  gint32         sfa_image;
+  gint32         sfa_drawable;
+  gint32         sfa_layer;
+  gint32         sfa_channel;
+  gint32         sfa_vectors;
+  gint32         sfa_display;
+  PikaRGB        sfa_color;
+  gint32         sfa_toggle;
+  gchar         *sfa_value;
+  SFAdjustment   sfa_adjustment;
+  SFFilename     sfa_file;
+  gchar         *sfa_font;
+  gchar         *sfa_gradient;
+  gchar         *sfa_palette;
+  gchar         *sfa_pattern;
+  gchar         *sfa_brush;
+  SFOption       sfa_option;
+  SFEnum         sfa_enum;
+} SFArgValue;
+
+typedef struct
+{
+  SFArgType   type;
+  gchar      *label;
+  SFArgValue  default_value;
+  SFArgValue  value;
+} SFArg;
+
+typedef struct
+{
+  gchar        *name;
+  gchar        *menu_label;
+  gchar        *blurb;
+  gchar        *author;
+  gchar        *copyright;
+  gchar        *date;
+  gchar        *image_types;
+
+  gint          n_args;
+  SFArg        *args;
+  SFDrawableArity drawable_arity;
+  GType           proc_class; /* PikaProcedure or PikaImageProcedure. */
+} SFScript;
+
+typedef struct
+{
+  SFScript *script;   /* script which defined this menu path and label */
+  gchar    *menu_path;
+} SFMenu;
+
+#endif /*  __SCRIPT_FU_TYPES__  */

plug-ins/script-fu/libscriptfu/script-fu-utils.c

@@ -0,0 +1,73 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#include "config.h"
+
+#include <string.h>
+
+#include <glib.h>
+
+#include "script-fu-utils.h"
+
+
+/*
+ * Escapes the special characters '\b', '\f', '\n', '\r', '\t', '\' and '"'
+ * in the string source by inserting a '\' before them.
+ */
+gchar *
+script_fu_strescape (const gchar *source)
+{
+  const guchar *p;
+  gchar        *dest;
+  gchar        *q;
+
+  g_return_val_if_fail (source != NULL, NULL);
+
+  p = (const guchar *) source;
+
+  /* Each source byte needs maximally two destination chars */
+  q = dest = g_malloc (strlen (source) * 2 + 1);
+
+  while (*p)
+    {
+      switch (*p)
+        {
+        case '\b':
+        case '\f':
+        case '\n':
+        case '\r':
+        case '\t':
+        case '\\':
+        case '"':
+          *q++ = '\\';
+          /* fallthrough */
+        default:
+          *q++ = *p;
+          break;
+        }
+
+      p++;
+    }
+
+  *q = 0;
+
+  return dest;
+}

plug-ins/script-fu/libscriptfu/script-fu-utils.h

@@ -0,0 +1,29 @@
+/* PIKA - Photo and Image Kooker Application
+ * a rebranding of The GNU Image Manipulation Program (created with heckimp)
+ * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
+ *
+ * Original copyright, applying to most contents (license remains unchanged): 
+ * 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 <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __SCRIPT_FU_UTILS_H__
+#define __SCRIPT_FU_UTILS_H__
+
+
+gchar * script_fu_strescape (const gchar *source);
+
+
+#endif /*  __SCRIPT_FU_UTILS__  */

plug-ins/script-fu/libscriptfu/script-fu.def

@@ -0,0 +1,17 @@
+EXPORTS
+  script_fu_extension_is_busy
+  script_fu_find_and_register_scripts
+  script_fu_find_scripts_create_PDB_proc_plugin
+  script_fu_find_scripts_list_proc_names
+  script_fu_get_success_msg
+  script_fu_init_embedded_interpreter
+  script_fu_interpret_string
+  script_fu_print_welcome
+  script_fu_redirect_output_to_gstr
+  script_fu_redirect_output_to_stdout
+  script_fu_register_post_command_callback
+  script_fu_register_quit_callback
+  script_fu_run_read_eval_print_loop
+  script_fu_search_path
+  script_fu_set_print_flag
+  script_fu_set_run_mode

plug-ins/script-fu/libscriptfu/tinyscheme/BUILDING

@@ -0,0 +1,139 @@
+        Building TinyScheme
+        -------------------
+
+The included makefile includes logic for Linux, Solaris and Win32, and can
+readily serve as an example for other OSes, especially Unixes. There are
+a lot of compile-time flags in TinyScheme (preprocessor defines) that can trim
+unwanted features. See next section. 'make all' and 'make clean' function as
+expected.
+
+Autoconfing TinyScheme was once proposed, but the distribution would not be
+so small anymore. There are few platform dependencies in TinyScheme, and in
+general compiles out of the box.
+
+     Customizing
+     -----------
+
+     The following symbols are defined to default values in scheme.h.
+     Use the -D flag of cc to set to either 1 or 0.
+
+     STANDALONE
+     Define this to produce a standalone interpreter.
+
+     USE_MATH
+     Includes math routines.
+
+     USE_CHAR_CLASSIFIERS
+     Includes character classifier procedures.
+
+     USE_ASCII_NAMES
+     Enable extended character notation based on ASCII names.
+
+     USE_STRING_PORTS
+     Enables string ports.
+
+     USE_ERROR_HOOK
+     To force system errors through user-defined error handling.
+     (see "Error handling")
+
+     USE_TRACING
+     To enable use of TRACING.
+
+     USE_COLON_HOOK
+     Enable use of qualified identifiers. (see "Colon Qualifiers - Packages")
+     Defining this as 0 has the rather drastic consequence that any code using
+     packages will stop working, and will have to be modified. It should only
+     be used if you *absolutely* need to use '::' in identifiers.
+
+     USE_STRCASECMP
+     Defines stricmp as strcasecmp, for Unix.
+
+     STDIO_ADDS_CR
+     Informs TinyScheme that stdio translates "\n" to "\r\n". For DOS/Windows.
+
+     USE_DL
+     Enables dynamically loaded routines. If you define this symbol, you
+     should also include dynload.c in your compile.
+
+     USE_PLIST
+     Enables property lists (not Standard Scheme stuff). Off by default.
+     
+     USE_NO_FEATURES
+     Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES,
+     USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK,
+     USE_DL.
+
+     USE_SCHEME_STACK
+     Enables 'cons' stack (the alternative is a faster calling scheme, which 
+     breaks continuations). Undefine it if you don't care about strict compatibility
+     but you do care about faster execution.
+
+
+     OS-X tip
+     --------
+     I don't have access to OS-X, but Brian Maher submitted the following tip:
+
+[1] Download and install fink (I installed fink in
+/usr/local/fink)
+[2] Install the 'dlcompat' package using fink as such:
+> fink install dlcompat
+[3] Make the following changes to the
+tinyscheme-1.32.tar.gz
+
+diff -r tinyscheme-1.32/dynload.c
+tinyscheme-1.32-new/dynload.c
+24c24
+< #define SUN_DL
+---
+> 
+Only in tinyscheme-1.32-new/: dynload.o
+Only in tinyscheme-1.32-new/: libtinyscheme.a Only in tinyscheme-1.32-new/: libtinyscheme.so diff -r tinyscheme-1.32/makefile tinyscheme-1.32-new/makefile
+33,34c33,43
+< LD = gcc
+< LDFLAGS = -shared
+---
+> #LD = gcc
+> #LDFLAGS = -shared
+> #DEBUG=-g -Wno-char-subscripts -O
+> #SYS_LIBS= -ldl
+> #PLATFORM_FEATURES= -DSUN_DL=1
+> 
+> # Mac OS X
+> CC = gcc
+> CFLAGS = -I/usr/local/fink/include
+> LD = gcc
+> LDFLAGS = -L/usr/local/fink/lib
+37c46
+< PLATFORM_FEATURES= -DSUN_DL=1
+---
+> PLATFORM_FEATURES= -DSUN_DL=1 -DOSX
+60c69
+<       $(CC) -I. -c $(DEBUG) $(FEATURES)
+$(DL_FLAGS) $<
+---
+>       $(CC) $(CFLAGS) -I. -c $(DEBUG)
+$(FEATURES) $(DL_FLAGS) $<
+66c75
+<       $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 
+---
+>       $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS)
+$(SYS_LIBS)
+Only in tinyscheme-1.32-new/: scheme
+diff -r tinyscheme-1.32/scheme.c
+tinyscheme-1.32-new/scheme.c
+60,61c60,61
+< #ifndef macintosh
+< # include <malloc.h>
+---
+> #ifdef OSX
+> /* Do nothing */
+62a63,65
+> # ifndef macintosh
+> #  include <malloc.h>
+> # else
+77c80,81
+< #endif /* macintosh */
+---
+> # endif /* macintosh */
+> #endif /* !OSX */
+Only in tinyscheme-1.32-new/: scheme.o

plug-ins/script-fu/libscriptfu/tinyscheme/CHANGES

@@ -0,0 +1,341 @@
+Change Log
+----------
+
+Version 1.42
+    Other changes:
+        - Fixed segfault crash caused by invalid syntax to cond  (PG)
+        - Fixed a bug in the close-port routine in init.scm
+        - Fixed possible crash loading file due to uninitialized variable  (MP)
+        - Don't use snprintf() in atom2str to return some fixed strings  (KC/MP)
+        - Added "tinyscheme" to the features list  (JaW)
+        - Added Sconstruct to allow building using scons  (AG)
+        - Fixed function prototype for scheme_init_new  (JuW)
+        - Make various limits configurable  (JuW)
+
+    Contributors:
+        Kevin Cozens, Mauro Persano, Pedro Gimeno, James Woodcock, Atanu Ghosh,
+        and Justus Winter.
+
+Version 1.41
+    Bugs fixed:
+        #3020389 - Added makefile section for Mac OS X  (SL)
+        #3286135 - Fixed num_mod routine which caused errors in use of modulo
+        #3290232 - Corrected version number shown on startup  (GM)
+        #3394882 - Added missing #if in opdefines.h around get and put  (DC)
+        #3395547 - Fix for the modulo procedure  (DC)
+        #3400290 - Optimized append to make it an O(n) operation  (DC)
+        #3493926 - Corrected flag used when building shared files on OSX  (J)
+
+    R5RS related changes:
+        #2866196 - Parser does not handle delimiters correctly
+        #3395548 - Add a decimal point to inexact numbers in atom2str  (DC)
+        #3399331 - Make min/max return inexact when any argument is inexact
+        #3399332 - Compatibility fix for expt.
+        #3399335 - Optional radix for string->number and number->string  (DC)
+        #3400202 - Append with one argument should not return a list  (DC)
+        #3400284 - Compatibility fix for integer?
+
+    Other changes:
+        - Added flags to makefile for MinGW/MSYS (TC)
+        - Moved variable declarations to avoid warnings with some compilers
+        - Don't print space after initial #( when printing vectors.
+        - Minor optimization for is_nonneg().
+        - No need to round integers in OP_ROUND (#3400284)
+        - Fixes to code that reports line number with error  (RC)
+
+    Contributors:
+        Kevin Cozens, Gordon McNutt, Doug Currie, Sean Long, Tim Cas, Joey,
+        Richard Copley, and CMarinier.
+
+Version 1.40
+    Bugs fixed:
+        #1964950 - Stop core dumps due to bad syntax in LET (and variants)
+        #2826594 - allow reverse to work on empty list (Tony Garnock-Jones)
+        Potential problem of arglist to foreign calls being wrongly GC'ed.
+        Fixed bug that read could loop forever (tehom).
+
+    API changes:
+        Exposed is_list and list_length.
+        Added scheme_register_foreign_func_list and declarations for it (tehom)
+        Defined *compile-hook* (tehom)
+
+    Other changes:
+        Updated is_list and list_length to handle circular lists.
+        Nested calling thru C has been made now safer (tehom)
+        Peter Michaux cleaned up port_rep_from_file
+        Added unwind-protect (tehom)
+        Some cleanups to in/outport and Eval_Cycle by Peter Michaux
+        Report error line number (Mostly by Sanel Zukan, back-compatibility by Tehom)
+
+    Contributors:
+        Kevin Cozens, Dimitrios Souflis, Tom Breton, Peter Michaux, Sanel Zukan,
+        and Tony Garnock-Jones.
+
+Version 1.39
+    Bugs fixed:
+        Fix for the load bug
+        Fixed parsing of octal coded characters. Fixes bug #1818018.
+        Added tests for when mk_vector is out of memory. Can't rely on sc->sink.
+        Fix for bug #1794369
+        Finished feature-request 1599947: scheme_apply0 etc return values.
+        Partly provided feature-request 1599947: Expose list_length, eqv, etc
+        Provided feature-request 1599945, Scheme->C->Scheme calling.
+        Fix for bug 1593861 (behavior of is_integer)
+        Fix for bug 1589711
+        Error checking of binding spec syntax in LET and LETREC. The bad syntax
+        was causing a segmentation fault in Linux. Complete fixes for bug #1817986.
+        Error checking of binding spec syntax in LET*
+        Bad syntax was causing core dump in Linux.
+        Fix for nasty gc bug
+
+    R5RS changes:
+        R5RS requires numbers to be of equal value AND of the same type (ie. both
+        exact or inexact) in order to return #t from eqv?. R5RS compliance fix.
+        String output ports now conform to SRFI-6
+
+    Other changes:
+        Drew Yao fixed buffer overflow problems in mk_sharp_const.
+        put OP_T0LVL in charge of reacting to EOF
+        file_push checks array bounds (patch from Ray Lehtiniemi)
+        Changed to always use snprintf (Patch due to Ramiro bsd1628)
+        Updated usage information using text from the Manual.txt file.
+
+Version 1.38
+    Interim release until the rewrite, mostly incorporating modifications
+    from Kevin Cozens. Small addition for Cygwin in the makefile, and
+    modifications by Andrew Guenther for Apple platforms.
+
+Version 1.37
+    Joe Buehler submitted reserve_cells.
+
+Version 1.36
+    Joe Buehler fixed a patch in the allocator.
+    Alexander Shendi moved the comment handling in the scanner, which
+    fixed an obscure bug for which Mike E had provided a patch as well.
+    Kevin Cozens has submitted some fixes and modifications which have
+    not been incorporated yet in their entirety.
+
+Version 1.35
+    Todd Showalter discovered that the number of free cells reported
+    after GC was incorrect, which could also cause unnecessary allocations.
+
+Version 1.34
+    Long missing version. Lots of bugfixes have accumulated in my email, so
+    I had to start using them. In this version, Keenan Pepper has submitted
+    a bugfix for the string comparison library procedure, Wouter Boeke
+    modified some code that was casting to the wrong type and crashed on
+    some machines, "SheppardCo" submitted a replacement "modulo" code and
+    Scott Fenton submitted lots of corrections that shut up some compiler
+    warnings. Brian Maher submitted instructions on how to build on OS-X.
+    I have to dig deeper into my mailbox and find earlier emails, too.
+
+Version 1.33
+    Charles Hayden fixed a nasty GC bug of the new stack frame, while in
+    the process of porting TinyScheme to C++. He also submitted other
+    changes, and other people also had comments or requests, but the GC
+    bug was so important that this version is put through the door to
+    correct it.
+
+Version 1.32
+    Stephen Gildea put some quality time on TinyScheme again, and made
+    a whole lot of changes to the interpreter that made it noticeably
+    faster.
+
+Version 1.31
+    Patches to the hastily-done version 1.30. Stephen Gildea fixed
+    some things done wrongly, and Richard Russo fixed the makefile
+    for building on Windows. Property lists (heritage from MiniScheme)
+    are now optional and have disappeared from the interface. They
+    should be considered as deprecated.
+
+Version 1.30
+    After many months, I followed Preston Bannister's advice of
+    using macros and a single source text to keep the enums and the
+    dispatch table in sync, and I used his contributed "opdefines.h".
+    Timothy Downs contributed a helpful function, "scheme_call".
+    Stephen Gildea contributed new versions of the makefile and
+    practically all other sources. He created a built-in STRING-APPEND,
+    and fixed a lot of other bugs.
+    Ruhi Bloodworth reported fixes necessary for OS X and a small
+    bug in dynload.c.
+
+Version 1.29
+    The previous version contained a lot of corrections, but there
+    were a lot more that still wait on a sheet of paper lost in a
+    carton someplace after my house move... Manuel Heras-Gilsanz
+    noticed this and resent his own contribution, which relies on
+    another bugfix that v.1.28 was missing: a problem with string
+    output, that this version fixes. I hope other people will take
+    the time to resend their contributions, if they didn't make it
+    to v.1.28.
+
+Version 1.28
+    Many people have contacted me with bugfixes or remarks in
+    the three months I was inactive. A lot of them spotted that
+    scheme_deinit crashed while reporting gc results. They suggested
+    that sc->outport be set to NIL in scheme_deinit, which I did.
+    Dennis Taylor remarked that OP_VALUEPRINT reset sc->value instead
+    of preserving it. He submitted a modification which I adopted
+    partially. David Hovemeyer sent me many little changes, that you
+    will find in version 1.28, and Patrice Stoessel modified the
+    float reader to conform to R5RS.
+
+Version 1.27
+    Version 1.27 is the successor of 1.25. Bug fixes only, but I had to
+    release them so that everybody can profit. 'Backchar' tried to write
+    back to the string, which obviously didn't work for const strings.
+    'Substring' didn't check for crossed start and end indices. Defines
+    changed to restore the ability to compile under MSVC.
+
+Version 1.26
+    Version 1.26 was never released. I changed a lot of things, in fact
+    too much, even the garbage collector, and hell broke loose. I'll
+    try a more gradual approach next time.
+
+Version 1.25
+    Types have been homogenized to be able to accommodate a different
+    representation. Plus, promises are no longer closures. Unfortunately,
+    I discovered that continuations and force/delay do not pass the SCM
+    test (and never did)... However, on the bright side, what little
+    modifications I did had a large impact on the footprint:
+    USE_NO_FEATURES now produces an object file of 63960 bytes on Linux!
+
+Version 1.24
+    SCM tests now pass again after change in atom2str.
+
+Version 1.23
+    Finally I managed to mess it up with my version control. Version
+    1.22 actually lacked some of the things I have been fixing in the
+    meantime. This should be considered as a complete replacement for
+    1.22.
+
+Version 1.22
+    The new ports had a bug in LOAD. MK_CLOSURE is introduced.
+    Shawn Wagner inquired about string->number and number->string.
+    I added string->atom and atom->string and defined the number
+    functions from them. Doing that, I fixed WRITE applied to symbols
+    (it didn't quote them). Unfortunately, minimum build is now
+    slightly larger than 64k... I postpone action because Jason's idea
+    might solve it elegantly.
+
+Version 1.21
+    Jason Felice submitted a radically different datatype representation
+    which he had implemented. While discussing its pros and cons, it
+    became apparent that the current implementation of ports suffered
+    from a grave fault: ports were not garbage-collected. I changed the
+    ports to be heap-allocated, which enabled the use of string ports
+    for loading. Jason also fixed errors in the garbage collection of
+    vectors. USE_VERBATIM is gone. "ssp_compiler.c" has a better solution
+    on HTML generation. A bug involving backslash notation in strings
+    has been fixed. '-c' flag now executes next argument as a stream of
+    Scheme commands. Foreign functions are now also heap allocated,
+    and scheme_define is used to define everything.
+
+Version 1.20
+    Tracing has been added. The toplevel loop has been slightly
+    rearranged. Backquote reading for vector templates has been
+    sanitized. Symbol interning is now correct. Arithmetic functions
+    have been corrected. APPLY, MAP, FOR-EACH, numeric comparison
+    functions fixed. String reader/writer understands \xAA notation.
+
+Version 1.19
+    Carriage Return now delimits identifiers. DOS-formatted Scheme files
+    can be used by Unix. Random number generator added to library.
+    Fixed some glitches of the new type-checking scheme. Fixed erroneous
+    (append '() 'a) behavior. Will continue with r4rstest.scm to
+    fix errors.
+
+Version 1.18
+    The FFI has been extended. USE_VERBOSE_GC has gone. Anyone wanting
+    the same functionality can put (gcverbose #t) in init.scm.
+    print-width was removed, along with three corresponding op-codes.
+    Extended character constants with ASCII names were added.
+    mk_counted_string paves the way for full support of binary strings.
+    As much as possible of the type-checking chores were delegated
+    to the inner loop, thus reducing the code size to less than 4200 loc!
+
+Version 1.17
+    Dynamically-loaded extensions are more fully integrated.
+    TinyScheme is now distributed under the BSD open-source license.
+
+Version 1.16
+    Dynamically-loaded extensions introduced (USE_DL).
+    Santeri Paavolainen found a race condition: When a cons is executed,
+    and each of the two arguments is a constructing function,  GC could
+    happen before all arguments are evaluated and cons() is called, and
+    the evaluated arguments would all be reclaimed!
+    Fortunately, such a case was rare in the code, although it is
+    a pitfall in new code and code in foreign functions. Currently, only
+    one such case remains, when COLON_HOOK is defined.
+
+Version 1.15
+    David Gould also contributed some changes that speed up operation.
+    Kirk Zurell fixed HASPROP.
+    The Garbage Collection didn't collect all the garbage...fixed.
+
+Version 1.14
+    Unfortunately, after Andre fixed the GC it became obvious that the
+    algorithm was too slow... Fortunately, David Gould found a way to
+    speed it up.
+
+Version 1.13
+    Silly bug involving division by zero resolved by Roland Kaufman.
+    Macintoch support from Shmulik Regev.
+    Float parser bug fixed by Alexander Shendi.
+    GC bug from Andru Luvisi.
+
+Version 1.12
+    Cis* incorrectly called isalpha() instead of isascii()
+    Added USE_CHAR_CLASSIFIERS, USE_STRING_PORTS.
+
+Version 1.11
+    BSDI defines isnumber... changed all similar functions to is_*
+    EXPT now has correct definition. Added FLOOR,CEILING,TRUNCATE
+    and ROUND, courtesy of Bengt Kleberg. Preprocessor symbols now
+    have values 1 or 0, and can be set as compiler defines (proposed
+    by Andy Ganor *months* ago). 'prompt' and 'InitFile' can now be
+    defined during compilation, too.
+
+Version 1.10
+    Another bug when file ends with comment!
+    Added DEFINE-MACRO in init.scm, courtesy of Andy Gaynor.
+
+Version 1.09
+    Removed bug when READ met EOF. lcm.
+
+Version 1.08
+    quotient,remainder and modulo. gcd.
+
+Version 1.07
+    '=>' in cond now exists
+    list? now checks for circularity
+    some reader bugs removed
+    Reader is more consistent wrt vectors
+    Quote and Quasiquote work with vectors
+
+Version 1.06
+    #! is now skipped
+    generic-assoc bug removed
+    strings are now managed differently, hack.txt is removed
+    various delicate points fixed
+
+Version 1.05
+    Support for scripts, *args*, "-1" option.
+    Various R5RS procedures.
+    *sharp-hook*
+    Handles unmatched parentheses.
+    New architecture for procedures.
+
+Version 1.04
+    Added missing T_ATOM bits...
+    Added vectors
+    Free-list is sorted by address, since vectors need consecutive cells.
+    (quit <exitcode>) for use with scripts
+
+Version 1.03 (26 Aug 1998):
+    Extended .h with useful functions for FFI
+    Library: with-input-* etc.
+    Finished R5RS I/O, added string ports.
+
+Version 1.02 (25 Aug 1998):
+    First part of R5RS I/O.

plug-ins/script-fu/libscriptfu/tinyscheme/COPYING

@@ -0,0 +1,31 @@
+                         LICENSE TERMS
+
+Copyright (c) 2000, Dimitrios Souflis
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+Neither the name of Dimitrios Souflis nor the names of the
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

plug-ins/script-fu/libscriptfu/tinyscheme/Manual.txt

@@ -0,0 +1,452 @@
+
+
+                       TinySCHEME Version 1.41
+
+                    "Safe if used as prescribed"
+                    -- Philip K. Dick, "Ubik"
+
+This software is open source, covered by a BSD-style license.
+Please read accompanying file COPYING.
+-------------------------------------------------------------------------------
+
+     This Scheme interpreter is based on MiniSCHEME version 0.85k4
+     (see miniscm.tar.gz in the Scheme Repository)
+     Original credits in file MiniSCHEMETribute.txt.
+
+     D. Souflis (dsouflis@acm.org)
+
+-------------------------------------------------------------------------------
+     What is TinyScheme?
+     -------------------
+
+     TinyScheme is a lightweight Scheme interpreter that implements as large
+     a subset of R5RS as was possible without getting very large and
+     complicated. It is meant to be used as an embedded scripting interpreter
+     for other programs. As such, it does not offer IDEs or extensive toolkits
+     although it does sport a small top-level loop, included conditionally.
+     A lot of functionality in TinyScheme is included conditionally, to allow
+     developers freedom in balancing features and footprint.
+
+     As an embedded interpreter, it allows multiple interpreter states to
+     coexist in the same program, without any interference between them.
+     Programmatically, foreign functions in C can be added and values
+     can be defined in the Scheme environment. Being a quite small program,
+     it is easy to comprehend, get to grips with, and use.
+
+     Known bugs
+     ----------
+
+     TinyScheme is known to misbehave when memory is exhausted.
+
+
+     Things that keep missing, or that need fixing
+     ---------------------------------------------
+
+     There are no hygienic macros. No rational or
+     complex numbers. No unwind-protect and call-with-values.
+
+     Maybe (a subset of) SLIB will work with TinySCHEME...
+
+     Decent debugging facilities are missing. Only tracing is supported
+     natively.
+
+
+     Scheme Reference
+     ----------------
+
+     If something seems to be missing, please refer to the code and
+     "init.scm", since some are library functions.  Refer to the MiniSCHEME
+     readme as a last resort.
+
+          Environments
+     (interaction-environment)
+     See R5RS. In TinySCHEME, immutable list of association lists.
+
+     (current-environment)
+     The environment in effect at the time of the call. An example of its
+     use and its utility can be found in the sample code that implements
+     packages in "init.scm":
+
+          (macro (package form)
+               `(apply (lambda ()
+                         ,@(cdr form)
+                         (current-environment))))
+
+     The environment containing the (local) definitions inside the closure
+     is returned as an immutable value.
+
+     (defined? <symbol>) (defined? <symbol> <environment>)
+     Checks whether the given symbol is defined in the current (or given)
+     environment.
+
+          Symbols
+     (gensym)
+     Returns a new interned symbol each time. Will probably move to the
+     library when string->symbol is implemented.
+
+          Directives
+     (gc)
+     Performs garbage collection immediately.
+
+     (gcverbose) (gcverbose <bool>)
+     The argument (defaulting to #t) controls whether GC produces
+     visible outcome.
+
+     (quit) (quit <num>)
+     Stops the interpreter and sets the 'retcode' internal field (defaults
+     to 0). When standalone, 'retcode' is returned as exit code to the OS.
+
+     (tracing <num>)
+     1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1).
+
+          Mathematical functions
+     Since rationals and complexes are absent, the respective functions
+     are also missing.
+     Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling,
+     trunc, round and also sqrt and expt when USE_MATH=1.
+     Number-theoretical quotient, remainder and modulo, gcd, lcm.
+     Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?,
+     exact->inexact. inexact->exact is a core function.
+
+          Type predicates
+     boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?,
+     char?,port?,input-port?,output-port?,procedure?,pair?,environment?',
+     vector?. Also closure?, macro?.
+
+          Types
+     Types supported:
+
+          Numbers (integers and reals)
+          Symbols
+          Pairs
+          Strings
+          Characters
+          Ports
+          Eof object
+          Environments
+          Vectors
+
+          Literals
+     String literals can contain escaped quotes \" as usual, but also
+     \n, \r, \t, \xDD (hex representations) and \DDD (octal representations).
+     Note also that it is possible to include literal newlines in string
+     literals, e.g.
+
+          (define s "String with newline here
+          and here
+          that can function like a HERE-string")
+
+     Character literals contain #\space and #\newline and are supplemented
+     with #\return and #\tab, with obvious meanings. Hex character
+     representations are allowed (e.g. #\x20 is #\space).
+     When USE_ASCII_NAMES is defined, various control characters can be
+     referred to by their ASCII name.
+     0	     #\nul	       17       #\dc1
+     1	     #\soh             18       #\dc2
+     2	     #\stx             19       #\dc3
+     3	     #\etx             20       #\dc4
+     4	     #\eot             21       #\nak
+     5	     #\enq             22       #\syn
+     6	     #\ack             23       #\etv
+     7	     #\bel             24       #\can
+     8	     #\bs              25       #\em
+     9	     #\ht              26       #\sub
+     10	     #\lf              27       #\esc
+     11	     #\vt              28       #\fs
+     12	     #\ff              29       #\gs
+     13	     #\cr              30       #\rs
+     14	     #\so              31       #\us
+     15	     #\si
+     16	     #\dle             127      #\del 		
+
+     Numeric literals support #x #o #b and #d. Flonums are currently read only
+     in decimal notation. Full grammar will be supported soon.
+
+          Quote, quasiquote etc.
+     As usual.
+
+          Immutable values
+     Immutable pairs cannot be modified by set-car! and set-cdr!.
+     Immutable strings cannot be modified via string-set!
+
+          I/O
+     As per R5RS, plus String Ports (see below).
+     current-input-port, current-output-port,
+     close-input-port, close-output-port, input-port?, output-port?,
+     open-input-file, open-output-file.
+     read, write, display, newline, write-char, read-char, peek-char.
+     char-ready? returns #t only for string ports, because there is no
+     portable way in stdio to determine if a character is available.
+     Also open-input-output-file, set-input-port, set-output-port (not R5RS)
+     Library: call-with-input-file, call-with-output-file,
+     with-input-from-file, with-output-from-file and
+     with-input-output-from-to-files, close-port and input-output-port?
+     (not R5RS).
+     String Ports: open-input-string, open-output-string, get-output-string,
+     open-input-output-string. Strings can be used with I/O routines.
+
+          Vectors
+     make-vector, vector, vector-length, vector-ref, vector-set!, list->vector,
+     vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS)
+
+          Strings
+     string, make-string, list->string, string-length, string-ref, string-set!,
+     substring, string->list, string-fill!, string-append, string-copy.
+     string=?, string<?, string>?, string>?, string<=?, string>=?.
+     (No string-ci*? yet). string->number, number->string. Also atom->string,
+     string->atom (not R5RS).
+
+          Symbols
+     symbol->string, string->symbol
+
+          Characters
+     integer->char, char->integer.
+     char=?, char<?, char>?, char<=?, char>=?.
+     (No char-ci*?)
+
+          Pairs & Lists
+     cons, car, cdr, list, length, map, for-each, foldr, list-tail,
+     list-ref, last-pair, reverse, append.
+     Also member, memq, memv, based on generic-member, assoc, assq, assv
+     based on generic-assoc.
+
+          Streams
+     head, tail, cons-stream
+
+          Control features
+     Apart from procedure?, also macro? and closure?
+     map, for-each, force, delay, call-with-current-continuation (or call/cc),
+     eval, apply. 'Forcing' a value that is not a promise produces the value.
+     There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in
+     the presence of continuations would require support from the abstract
+     machine itself.
+
+          Property lists
+     TinyScheme inherited from MiniScheme property lists for symbols.
+     put, get.
+
+          Dynamically-loaded extensions
+     (load-extension <filename without extension>)
+     Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use
+     of the ld.so.conf file or the LD_RUN_PATH system variable in order to place
+     the library in a directory other than the current one. Please refer to the
+     appropriate 'man' page.
+
+          Esoteric procedures
+     (oblist)
+     Returns the oblist, an immutable list of all the symbols.
+
+     (macro-expand <form>)
+     Returns the expanded form of the macro call denoted by the argument
+
+     (define-with-return (<procname> <args>...) <body>)
+     Like plain 'define', but makes the continuation available as 'return'
+     inside the procedure. Handy for imperative programs.
+
+     (new-segment <num>)
+     Allocates more memory segments.
+
+     defined?
+     See "Environments"
+
+     (get-closure-code <closure>)
+     Gets the code as scheme data.
+
+     (make-closure <code> <environment>)
+     Makes a new closure in the given environment.
+
+          Obsolete procedures
+     (print-width <object>)
+
+     Programmer's Reference
+     ----------------------
+
+     The interpreter state is initialized with "scheme_init".
+     Custom memory allocation routines can be installed with an alternate
+     initialization function: "scheme_init_custom_alloc".
+     Files can be loaded with "scheme_load_file". Strings containing Scheme
+     code can be loaded with "scheme_load_string". It is a good idea to
+     "scheme_load" init.scm before anything else.
+
+     External data for keeping external state (of use to foreign functions)
+     can be installed with "scheme_set_external_data".
+     Foreign functions are installed with "assign_foreign". Additional
+     definitions can be added to the interpreter state, with "scheme_define"
+     (this is the way HTTP header data and HTML form data are passed to the
+     Scheme script in the Altera SQL Server). If you wish to define the
+     foreign function in a specific environment (to enhance modularity),
+     use "assign_foreign_env".
+
+     The procedure "scheme_apply0" has been added with persistent scripts in
+     mind. Persistent scripts are loaded once, and every time they are needed
+     to produce HTTP output, appropriate data are passed through global
+     definitions and function "main" is called to do the job. One could
+     add easily "scheme_apply1" etc.
+
+     The interpreter state should be deinitialized with "scheme_deinit".
+
+     DLLs containing foreign functions should define a function named
+     init_<base-name>. E.g. foo.dll should define init_foo, and bar.so
+     should define init_bar. This function should assign_foreign any foreign
+     function contained in the DLL.
+
+     The first dynamically loaded extension available for TinyScheme is
+     a regular expression library. Although it's by no means an
+     established standard, this library is supposed to be installed in
+     a directory mirroring its name under the TinyScheme location.
+
+
+     Foreign Functions
+     -----------------
+
+     The user can add foreign functions in C. For example, a function
+     that squares its argument:
+
+          pointer square(scheme *sc, pointer args) {
+           if(args!=sc->NIL) {
+               if(sc->isnumber(sc->pair_car(args))) {
+                    double v=sc->rvalue(sc->pair_car(args));
+                    return sc->mk_real(sc,v*v);
+               }
+           }
+           return sc->NIL;
+          }
+
+   Foreign functions are now defined as closures:
+
+   sc->interface->scheme_define(
+        sc,
+        sc->global_env,
+        sc->interface->mk_symbol(sc,"square"),
+        sc->interface->mk_foreign_func(sc, square));
+
+
+     Foreign functions can use the external data in the "scheme" struct
+     to implement any kind of external state.
+
+     External data are set with the following function:
+          void scheme_set_external_data(scheme *sc, void *p);
+
+     As of v.1.17, the canonical way for a foreign function in a DLL to
+     manipulate Scheme data is using the function pointers in sc->interface.
+
+     Standalone
+     ----------
+
+     Usage: tinyscheme -?
+     or:    tinyscheme [<file1> <file2> ...]
+     followed by
+	       -1 <file> [<arg1> <arg2> ...]
+	       -c <Scheme commands> [<arg1> <arg2> ...]
+     assuming that the executable is named tinyscheme.
+
+     Use - in the place of a filename to denote stdin.
+     The -1 flag is meant for #! usage in shell scripts. If you specify
+          #! /somewhere/tinyscheme -1
+     then tinyscheme will be called to process the file. For example, the
+     following script echoes the Scheme list of its arguments.
+
+	       #! /somewhere/tinyscheme -1
+	       (display *args*)
+
+     The -c flag permits execution of arbitrary Scheme code.
+
+
+     Error Handling
+     --------------
+
+     Errors are recovered from without damage. The user can install their
+     own handler for system errors, by defining *error-hook*. Defining
+     to '() gives the default behavior, which is equivalent to "error".
+     USE_ERROR_HOOK must be defined.
+
+     A simple exception handling mechanism can be found in "init.scm".
+     A new syntactic form is introduced:
+
+          (catch <expr returned exceptionally>
+               <expr1> <expr2> ... <exprN>)
+
+     "Catch" establishes a scope spanning multiple call-frames
+     until another "catch" is encountered.
+
+     Exceptions are thrown with:
+
+          (throw "message")
+
+     If used outside a (catch ...), reverts to (error "message").
+
+     Example of use:
+
+          (define (foo x) (write x) (newline) (/ x 0))
+
+          (catch (begin (display "Error!\n") 0)
+               (write "Before foo ... ")
+               (foo 5)
+               (write "After foo"))
+
+     The exception mechanism can be used even by system errors, by
+
+          (define *error-hook* throw)
+
+     which makes use of the error hook described above.
+
+     If necessary, the user can devise their own exception mechanism with
+     tagged exceptions etc.
+
+
+     Reader extensions
+     -----------------
+
+     When encountering an unknown character after '#', the user-specified
+     procedure *sharp-hook* (if any), is called to read the expression.
+     This can be used to extend the reader to handle user-defined constants
+     or whatever. It should be a procedure without arguments, reading from
+     the current input port (which will be the load-port).
+
+
+     Colon Qualifiers - Packages
+     ---------------------------
+
+     When USE_COLON_HOOK=1:
+     The lexer now recognizes the construction <qualifier>::<symbol> and
+     transforms it in the following manner (T is the transformation function):
+
+          T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>)
+
+     where <qualifier> is a symbol not containing any double-colons.
+
+     As the definition is recursive, qualifiers can be nested.
+     The user can define their own *colon-hook*, to handle qualified names.
+     By default, "init.scm" defines *colon-hook* as EVAL. Consequently,
+     the qualifier must denote a Scheme environment, such as one returned
+     by (interaction-environment). "Init.scm" defines a new syntantic form,
+     PACKAGE, as a simple example. It is used like this:
+
+          (define toto
+               (package
+                    (define foo 1)
+                    (define bar +)))
+
+          foo                                     ==>  Error, "foo" undefined
+          (eval 'foo)                             ==>  Error, "foo" undefined
+          (eval 'foo toto)                        ==>  1
+          toto::foo                               ==>  1
+          ((eval 'bar toto) 2 (eval 'foo toto))   ==>  3
+          (toto::bar 2 toto::foo)                 ==>  3
+          (eval (bar 2 foo) toto)                 ==>  3
+
+     If the user installs another package infrastructure, he must define
+     a new 'package' procedure or macro to retain compatibility with supplied
+     code.
+
+     Note: Older versions used ':' as a qualifier. Unfortunately, the use
+     of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially
+     precludes its use as a real qualifier.
+
+
+
+
+
+
+
+

plug-ins/script-fu/libscriptfu/tinyscheme/MiniSCHEMETribute.txt

@@ -0,0 +1,88 @@
+     TinyScheme would not exist if it wasn't for MiniScheme. I had just
+     written the HTTP server for Ovrimos SQL Server, and I was lamenting the
+     lack of a scripting language. Server-side Javascript would have been the
+     preferred solution, had there been a Javascript interpreter I could
+     lay my hands on. But there weren't. Perl would have been another solution,
+     but it was probably ten times bigger that the program it was supposed to
+     be embedded in. There would also be thorny licencing issues. 
+     
+     So, the obvious thing to do was find a truly small interpreter. Forth
+     was a language I had once quasi-implemented, but the difficulty of
+     handling dynamic data and the weirdness of the language put me off. I then
+     looked around for a LISP interpreter, the next thing I knew was easy to
+     implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre
+     et Marie Curie) had given way to Common Lisp, a megalith of a language!
+     Then my search lead me to Scheme, a language I knew was very orthogonal
+     and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I 
+     fell in love with it! What if it lacked floating-point numbers and 
+     strings! The rest, as they say, is history.
+     
+     Below  are the original credits. Don't email Akira KIDA, the address has
+     changed.
+     
+     ---------- Mini-Scheme Interpreter Version 0.85 ----------
+
+                coded by Atsushi Moriwaki (11/5/1989)
+
+            E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
+
+               THIS SOFTWARE IS IN THE PUBLIC DOMAIN
+               ------------------------------------
+ This software is completely free to copy, modify and/or re-distribute.
+ But I would appreciate it if you left my name on the code as the author.
+
+  This version has been modified by R.C. Secrist.
+
+  Mini-Scheme is now maintained by Akira KIDA.
+
+  This is a revised and modified version by Akira KIDA.
+   current version is 0.85k4 (15 May 1994)
+
+  Please send suggestions, bug reports and/or requests to:
+        <SDI00379@niftyserve.or.jp>
+
+
+     Features compared to MiniSCHEME
+     -------------------------------
+
+     All code is now reentrant. Interpreter state is held in a 'scheme'
+     struct, and many interpreters can coexist in the same program, possibly
+     in different threads. The user can specify user-defined memory allocation
+     primitives. (see "Programmer's Reference")
+
+     The reader is more consistent.
+
+     Strings, characters and flonums are supported. (see "Types")
+
+     Files being loaded can be nested up to some depth.
+
+     R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O")
+
+     Vectors exist.
+
+     As a standalone application, it supports command-line arguments.
+     (see "Standalone")
+
+     Running out of memory is now handled.
+
+     The user can add foreign functions in C. (see "Foreign Functions")
+
+     The code has been changed slightly, core functions have been moved
+     to the library, behavior has been aligned with R5RS etc.
+
+     Support has been added for user-defined error recovery.
+     (see "Error Handling")
+
+     Support has been added for modular programming.
+     (see "Colon Qualifiers - Packages")
+
+     To enable this, EVAL has changed internally, and can
+     now take two arguments, as per R5RS. Environments are supported.
+     (see "Colon Qualifiers - Packages")
+
+     Promises are now evaluated once only.
+
+     (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...))
+
+     The reader can be extended using new #-expressions
+     (see "Reader extensions")

plug-ins/script-fu/libscriptfu/tinyscheme/README

@@ -0,0 +1,14 @@
+This directory contains a version of TinyScheme which has been modified
+to support UTF-8 coded strings. The strings stored in a data cell are
+expected to be in UTF-8 format. This allows the continued use of gchar
+pointers to pass around the strings. Processing the strings will require
+conversion to unicode at times depending on the specific operation that
+needs to be done on the UTF-8 coded strings.
+
+The string length value stored in a data cell is the length in bytes of that
+string including the terminating NUL.
+
+Routines that want a string length for a UTF-8 coded string will be passed
+the number of characters and not the number of bytes. If the number of bytes
+is needed, the normal call to strlen() will work.
+

plug-ins/script-fu/libscriptfu/tinyscheme/dynload.c

@@ -0,0 +1,152 @@
+/* dynload.c Dynamic Loader for TinyScheme */
+/* Original Copyright (c) 1999 Alexander Shendi     */
+/* Modifications for NT and dl_* interface, scm_load_ext: D. Souflis */
+/* Refurbished by Stephen Gildea */
+
+#define _SCHEME_SOURCE
+#include "dynload.h"
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <glib/glib.h>
+
+#ifndef MAXPATHLEN
+# define MAXPATHLEN 1024
+#endif
+
+static void make_filename(const char *name, char *filename);
+static void make_init_fn(const char *name, char *init_fn);
+
+#ifdef _WIN32
+# include <windows.h>
+#else
+typedef void *HMODULE;
+typedef void (*FARPROC)();
+#ifndef SUN_DL
+#define SUN_DL
+#endif
+#include <dlfcn.h>
+#endif
+
+#ifdef _WIN32
+
+#define PREFIX ""
+#define SUFFIX ".dll"
+
+ static void display_w32_error_msg(const char *additional_message)
+ {
+   LPVOID msg_buf;
+
+   FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+                 NULL, GetLastError(), 0,
+                 (LPTSTR)&msg_buf, 0, NULL);
+   fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf);
+   LocalFree(msg_buf);
+ }
+
+static HMODULE dl_attach(const char *module) {
+  wchar_t *module_utf16 = g_utf8_to_utf16 (module, -1, NULL, NULL, NULL);
+  HMODULE  dll          = NULL;
+
+  if (!module_utf16)
+    return NULL;
+
+  dll = LoadLibraryW (module_utf16);
+  if (!dll)
+    display_w32_error_msg (module);
+
+  free (module_utf16);
+  return dll;
+}
+
+static FARPROC dl_proc(HMODULE mo, const char *proc) {
+  FARPROC procedure = GetProcAddress(mo,proc);
+  if (!procedure) display_w32_error_msg(proc);
+  return procedure;
+}
+
+static void dl_detach(HMODULE mo) {
+ (void)FreeLibrary(mo);
+}
+
+#elif defined(SUN_DL)
+
+#include <dlfcn.h>
+
+#define PREFIX "lib"
+#define SUFFIX ".so"
+
+static HMODULE dl_attach(const char *module) {
+  HMODULE so=dlopen(module,RTLD_LAZY);
+  if(!so) {
+    fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror());
+  }
+  return so;
+}
+
+static FARPROC dl_proc(HMODULE mo, const char *proc) {
+  const char *errmsg;
+  FARPROC fp=(FARPROC)dlsym(mo,proc);
+  if ((errmsg = dlerror()) == 0) {
+    return fp;
+  }
+  fprintf(stderr, "Error initializing scheme module \"%s\": %s\n", proc, errmsg);
+ return 0;
+}
+
+static void dl_detach(HMODULE mo) {
+ (void)dlclose(mo);
+}
+#endif
+
+pointer scm_load_ext(scheme *sc, pointer args)
+{
+   pointer first_arg;
+   pointer retval;
+   char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6];
+   char *name;
+   HMODULE dll_handle;
+   void (*module_init)(scheme *sc);
+
+   if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) {
+      name = string_value(first_arg);
+      make_filename(name,filename);
+      make_init_fn(name,init_fn);
+      dll_handle = dl_attach(filename);
+      if (dll_handle == 0) {
+         retval = sc -> F;
+      }
+      else {
+         module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn);
+         if (module_init != 0) {
+            (*module_init)(sc);
+            retval = sc -> T;
+         }
+         else {
+            retval = sc->F;
+         }
+      }
+   }
+   else {
+      retval = sc -> F;
+   }
+
+  return(retval);
+}
+
+static void make_filename(const char *name, char *filename) {
+ strcpy(filename,name);
+ strcat(filename,SUFFIX);
+}
+
+static void make_init_fn(const char *name, char *init_fn) {
+ const char *p=strrchr(name,'/');
+ if(p==0) {
+     p=name;
+ } else {
+     p++;
+ }
+ strcpy(init_fn,"init_");
+ strcat(init_fn,p);
+}

plug-ins/script-fu/libscriptfu/tinyscheme/dynload.h

@@ -0,0 +1,12 @@
+/* dynload.h */
+/* Original Copyright (c) 1999 Alexander Shendi     */
+/* Modifications for NT and dl_* interface: D. Souflis */
+
+#ifndef DYNLOAD_H
+#define DYNLOAD_H
+
+#include "scheme-private.h"
+
+SCHEME_EXPORT pointer scm_load_ext(scheme *sc, pointer arglist);
+
+#endif

plug-ins/script-fu/libscriptfu/tinyscheme/hack.txt

@@ -0,0 +1,233 @@
+
+                              How to hack TinyScheme
+                              ----------------------
+
+     TinyScheme is easy to learn and modify. It is structured like a
+     meta-interpreter, only it is written in C. All data are Scheme
+     objects, which facilitates both understanding/modifying the
+     code and reifying the interpreter workings.
+
+     In place of a dry description, we will pace through the addition
+     of a useful new datatype: garbage-collected memory blocks.
+     The interface will be:
+
+          (make-block <n> [<fill>]) makes a new block of the specified size
+               optionally filling it with a specified byte
+          (block? <obj>)
+          (block-length <block>)
+          (block-ref <block> <index>) retrieves byte at location
+          (block-set! <block> <index> <byte>) modifies byte at location
+     
+     In the sequel, lines that begin with '>' denote lines to add to the
+     code. Lines that begin with '|' are just citations of existing code.
+     Lines that begin with X are deleted.
+
+     First of all, we need to assign a typeid to our new type. Typeids
+     in TinyScheme are small integers declared in an enum, very close to
+     the top of scheme.c; it begins with T_STRING. Add a new one before the
+     end, call it T_MEMBLOCK. Adjust T_LAST_SYSTEM_TYPE.
+
+|      T_ENVIRONMENT=14,
+X      T_LAST_SYSTEM_TYPE=14
+>      T_MEMBLOCK=15,
+>      T_LAST_SYSTEM_TYPE=15
+|    };
+
+     Then, some helper macros would be useful. Go to where is_string() and
+     the rest are defined and define:
+
+>    int is_memblock(pointer p)      { return (type(p)==T_MEMBLOCK); }
+
+     This actually is a function, because it is meant to be exported by
+     scheme.h. If no foreign function will ever manipulate a memory block,
+     you can instead define it as a macro
+
+>    #define is_memblock(p) (type(p)==T_MEMBLOCK)
+
+     Then we make space for the new type in the main data structure:
+     struct cell. As it happens, the _string part of the union _object
+     (that is used to hold character strings) has two fields that suit us:
+
+|         struct {
+|              char   *_svalue;
+|              int   _keynum;
+|         } _string;
+
+     We can use _svalue to hold the actual pointer and _keynum to hold its
+     length. If we couldn't reuse existing fields, we could always add other
+     alternatives in union _object.
+
+     We then proceed to write the function that actually makes a new block.
+     For conformance reasons, we name it mk_memblock
+
+>     static pointer mk_memblock(scheme *sc, int len, char fill) {
+>          pointer x;
+>          char *p=(char*)sc->malloc(len);
+>
+>          if(p==0) {
+>               return sc->NIL;
+>          }
+>          x = get_cell(sc, sc->NIL, sc->NIL);
+>
+>          typeflag(x) = T_MEMBLOCK|T_ATOM;
+>          strvalue(x)=p;
+>          keynum(x)=len;
+>          memset(p,fill,len);
+>          return (x);
+>     }
+
+     The memory used by the MEMBLOCK will have to be freed when the cell
+     is reclaimed during garbage collection. There is a placeholder for
+     that staff, function finalize_cell(), currently handling strings only.
+
+|     static void finalize_cell(scheme *sc, pointer a) {
+|          if(is_string(a)) {
+|               sc->free(strvalue(a));
+>          else if(is_memblock(a)) {
+>               sc->free(strvalue(a));
+|          } else if(is_port(a)) {
+
+     There are no MEMBLOCK literals, so we don't concern ourselves with
+     the READER part (yet!). We must cater to the PRINTER, though. We
+     add one case more in atom2str().
+
+|    } else if (is_foreign(l)) {
+|         p = sc->strbuff;
+|         snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
+>    } else if (ismemblock(l)) {
+>         p = "#<MEMBLOCK>";
+|    } else if (is_continuation(l)) {
+|         p = "#<CONTINUATION>";
+|    } else {
+
+     Whenever a MEMBLOCK is displayed, it will look like that.
+
+     Now, we must add the interface functions: constructor, predicate,
+     accessor, modifier. We must in fact create new op-codes for the
+     virtual machine underlying TinyScheme. Since version 1.30, TinyScheme
+     uses macros and a single source text to keep the enums and the
+     dispatch table in sync. That's where the op-codes are declared. Note
+     that the opdefines.h file uses unusually long lines to accommodate
+     all the information; adjust your editor to handle this. The file has
+     six columns: A to Z. they contain:
+       - Column A is the name of a routine to handle the scheme function.
+       - Column B is the name the scheme function.
+       - Columns C and D are the minimum and maximum number of arguments
+         that are accepted by the scheme function.
+       - Column E is a set of flags that are used when the interpreter
+         verifies that the passed parameters are of the correct type.
+       - Column F is used to create a set of enums. The enum is used in a
+         switch in the routine listed in column A to get to the code that
+	 does the work needed for the scheme function.
+     For reasons of cohesion, we add the new op-codes right after those
+     for vectors:
+
+|   _OP_DEF(opexe_2, "vector-set!",                    3,  3,       TST_VECTOR TST_NATURAL TST_ANY,  OP_VECSET           )
+>   _OP_DEF(opexe_2, "make-block",                     1,  2,       TST_NATURAL TST_CHAR,            OP_MKBLOCK          )
+>   _OP_DEF(opexe_2, "block-length",                   1,  1,       T_MEMBLOCK,                      OP_BLOCKLEN         )
+>   _OP_DEF(opexe_2, "block-ref",                      2,  2,       T_MEMBLOCK TST_NATURAL,          OP_BLOCKREF         )
+>   _OP_DEF(opexe_2, "block-set!",                     1,  1,       T_MEMBLOCK TST_NATURAL TST_CHAR, OP_BLOCKSET         )
+|   _OP_DEF(opexe_3, "not",                            1,  1,       TST_NONE,                        OP_NOT              )
+
+     We add the predicate along the other predicates:
+
+|   _OP_DEF(opexe_3, "vector?",                        1,  1,       TST_ANY,                         OP_VECTORP          )
+>   _OP_DEF(opexe_3, "block?",                         1,  1,       TST_ANY,                         OP_BLOCKP           )
+|   _OP_DEF(opexe_3, "eq?",                            2,  2,       TST_ANY,                         OP_EQ               )
+
+     All that remains is to write the actual processing in opexe_2, right
+     after OP_VECSET.
+
+>     case OP_MKBLOCK: { /* make-block */
+>          int fill=0;
+>          int len;
+>
+>          if(!isnumber(car(sc->args))) {
+>               Error_1(sc,"make-block: not a number:",car(sc->args));
+>          }
+>          len=ivalue(car(sc->args));
+>          if(len<=0) {
+>               Error_1(sc,"make-block: not positive:",car(sc->args));
+>          }
+>
+>          if(cdr(sc->args)!=sc->NIL) {
+>               if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) {
+>                    Error_1(sc,"make-block: not a positive number:",cadr(sc->args));
+>               }
+>               fill=charvalue(cadr(sc->args))%255;
+>          }
+>          s_return(sc,mk_memblock(sc,len,(char)fill));
+>     }
+>
+>     case OP_BLOCKLEN:  /* block-length */
+>          if(!ismemblock(car(sc->args))) {
+>               Error_1(sc,"block-length: not a memory block:",car(sc->args));
+>          }
+>          s_return(sc,mk_integer(sc,keynum(car(sc->args))));
+>
+>     case OP_BLOCKREF: { /* block-ref */
+>          char *str;
+>          int index;
+>
+>          if(!ismemblock(car(sc->args))) {
+>               Error_1(sc,"block-ref: not a memory block:",car(sc->args));
+>          }
+>          str=strvalue(car(sc->args));
+>
+>          if(cdr(sc->args)==sc->NIL) {
+>               Error_0(sc,"block-ref: needs two arguments");
+>          }
+>          if(!isnumber(cadr(sc->args))) {
+>               Error_1(sc,"block-ref: not a number:",cadr(sc->args));
+>          }
+>          index=ivalue(cadr(sc->args));
+>
+>          if(index<0 || index>=keynum(car(sc->args))) {
+>               Error_1(sc,"block-ref: out of bounds:",cadr(sc->args));
+>          }
+>
+>          s_return(sc,mk_integer(sc,str[index]));
+>     }
+>
+>     case OP_BLOCKSET: { /* block-set! */
+>          char *str;
+>          int index;
+>          int c;
+>
+>          if(!ismemblock(car(sc->args))) {
+>               Error_1(sc,"block-set!: not a memory block:",car(sc->args));
+>          }
+>          if(isimmutable(car(sc->args))) {
+>               Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args));
+>          }
+>          str=strvalue(car(sc->args));
+>
+>          if(cdr(sc->args)==sc->NIL) {
+>               Error_0(sc,"block-set!: needs three arguments");
+>          }
+>          if(!isnumber(cadr(sc->args))) {
+>               Error_1(sc,"block-set!: not a number:",cadr(sc->args));
+>          }
+>          index=ivalue(cadr(sc->args));
+>          if(index<0 || index>=keynum(car(sc->args))) {
+>               Error_1(sc,"block-set!: out of bounds:",cadr(sc->args));
+>          }
+>
+>          if(cddr(sc->args)==sc->NIL) {
+>               Error_0(sc,"block-set!: needs three arguments");
+>          }
+>          if(!isinteger(caddr(sc->args))) {
+>               Error_1(sc,"block-set!: not an integer:",caddr(sc->args));
+>          }
+>          c=ivalue(caddr(sc->args))%255;
+>
+>          str[index]=(char)c;
+>          s_return(sc,car(sc->args));
+>     }
+
+     Same for the predicate in opexe_3.
+
+|     case OP_VECTORP:     /* vector? */
+|          s_retbool(isvector(car(sc->args)));
+>     case OP_BLOCKP:     /* block? */
+>          s_retbool(ismemblock(car(sc->args)));

plug-ins/script-fu/libscriptfu/tinyscheme/init.scm

@@ -0,0 +1,716 @@
+;    Initialization file for TinySCHEME 1.41
+
+; Per R5RS, up to four deep compositions should be defined
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+;;;; Utility to ease macro creation
+(define (macro-expand form)
+     ((eval (get-closure-code (eval (car form)))) form))
+
+(define (macro-expand-all form)
+   (if (macro? form)
+      (macro-expand-all (macro-expand form))
+      form))
+
+(define *compile-hook* macro-expand-all)
+
+
+(macro (unless form)
+     `(if (not ,(cadr form)) (begin ,@(cddr form))))
+
+(macro (when form)
+     `(if ,(cadr form) (begin ,@(cddr form))))
+
+; DEFINE-MACRO Contributed by Andy Gaynor
+(macro (define-macro dform)
+  (if (symbol? (cadr dform))
+    `(macro ,@(cdr dform))
+    (let ((form (gensym)))
+      `(macro (,(caadr dform) ,form)
+         (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
+
+; Utilities for math. Notice that inexact->exact is primitive,
+; but exact->inexact is not.
+(define exact? integer?)
+(define (inexact? x) (and (real? x) (not (integer? x))))
+(define (even? n) (= (remainder n 2) 0))
+(define (odd? n) (not (= (remainder n 2) 0)))
+(define (zero? n) (= n 0))
+(define (positive? n) (> n 0))
+(define (negative? n) (< n 0))
+(define complex? number?)
+(define rational? real?)
+(define (abs n) (if (>= n 0) n (- n)))
+(define (exact->inexact n) (* n 1.0))
+(define (<> n1 n2) (not (= n1 n2)))
+
+; min and max must return inexact if any arg is inexact; use (+ n 0.0)
+(define (max . lst)
+  (foldr (lambda (a b)
+           (if (> a b)
+             (if (exact? b) a (+ a 0.0))
+             (if (exact? a) b (+ b 0.0))))
+         (car lst) (cdr lst)))
+(define (min . lst)
+  (foldr (lambda (a b)
+           (if (< a b)
+             (if (exact? b) a (+ a 0.0))
+             (if (exact? a) b (+ b 0.0))))
+         (car lst) (cdr lst)))
+
+(define (succ x) (+ x 1))
+(define (pred x) (- x 1))
+(define gcd
+  (lambda a
+    (if (null? a)
+      0
+      (let ((aa (abs (car a)))
+            (bb (abs (cadr a))))
+         (if (= bb 0)
+              aa
+              (gcd bb (remainder aa bb)))))))
+(define lcm
+  (lambda a
+    (if (null? a)
+      1
+      (let ((aa (abs (car a)))
+            (bb (abs (cadr a))))
+         (if (or (= aa 0) (= bb 0))
+             0
+             (abs (* (quotient aa (gcd aa bb)) bb)))))))
+
+
+(define (string . charlist)
+     (list->string charlist))
+
+(define (list->string charlist)
+     (let* ((len (length charlist))
+            (newstr (make-string len))
+            (fill-string!
+               (lambda (str i len charlist)
+                    (if (= i len)
+                         str
+                         (begin (string-set! str i (car charlist))
+                         (fill-string! str (+ i 1) len (cdr charlist)))))))
+          (fill-string! newstr 0 len charlist)))
+
+(define (string-fill! s e)
+     (let ((n (string-length s)))
+          (let loop ((i 0))
+               (if (= i n)
+                    s
+                    (begin (string-set! s i e) (loop (succ i)))))))
+
+(define (string->list s)
+     (let loop ((n (pred (string-length s))) (l '()))
+          (if (= n -1)
+               l
+               (loop (pred n) (cons (string-ref s n) l)))))
+
+(define (string-copy str)
+     (string-append str))
+
+(define (string->anyatom str pred)
+     (let* ((a (string->atom str)))
+       (if (pred a) a
+         (error "string->xxx: not a xxx" a))))
+
+(define (string->number str . base)
+    (let ((n (string->atom str (if (null? base) 10 (car base)))))
+        (if (number? n) n #f)))
+
+(define (anyatom->string n pred)
+  (if (pred n)
+      (atom->string n)
+      (error "xxx->string: not a xxx" n)))
+
+(define (number->string n . base)
+    (atom->string n (if (null? base) 10 (car base))))
+
+
+(define (char-cmp? cmp a b)
+     (cmp (char->integer a) (char->integer b)))
+(define (char-ci-cmp? cmp a b)
+     (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+
+(define (char=? a b) (char-cmp? = a b))
+(define (char<? a b) (char-cmp? < a b))
+(define (char>? a b) (char-cmp? > a b))
+(define (char<=? a b) (char-cmp? <= a b))
+(define (char>=? a b) (char-cmp? >= a b))
+
+(define (char-ci=? a b) (char-ci-cmp? = a b))
+(define (char-ci<? a b) (char-ci-cmp? < a b))
+(define (char-ci>? a b) (char-ci-cmp? > a b))
+(define (char-ci<=? a b) (char-ci-cmp? <= a b))
+(define (char-ci>=? a b) (char-ci-cmp? >= a b))
+
+; Note the trick of returning (cmp x y)
+(define (string-cmp? chcmp cmp a b)
+     (let ((na (string-length a)) (nb (string-length b)))
+          (let loop ((i 0))
+               (cond
+                    ((= i na)
+                         (if (= i nb) (cmp 0 0) (cmp 0 1)))
+                    ((= i nb)
+                         (cmp 1 0))
+                    ((chcmp = (string-ref a i) (string-ref b i))
+                         (loop (succ i)))
+                    (else
+                         (chcmp cmp (string-ref a i) (string-ref b i)))))))
+
+
+(define (string=? a b) (string-cmp? char-cmp? = a b))
+(define (string<? a b) (string-cmp? char-cmp? < a b))
+(define (string>? a b) (string-cmp? char-cmp? > a b))
+(define (string<=? a b) (string-cmp? char-cmp? <= a b))
+(define (string>=? a b) (string-cmp? char-cmp? >= a b))
+
+(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
+(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
+(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
+(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
+(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
+
+(define (list . x) x)
+
+(define (foldr f x lst)
+     (if (null? lst)
+          x
+          (foldr f (f x (car lst)) (cdr lst))))
+
+(define (unzip1-with-cdr . lists)
+  (unzip1-with-cdr-iterative lists '() '()))
+
+(define (unzip1-with-cdr-iterative lists cars cdrs)
+  (if (null? lists)
+      (cons cars cdrs)
+      (let ((car1 (caar lists))
+            (cdr1 (cdar lists)))
+        (unzip1-with-cdr-iterative
+          (cdr lists)
+          (append cars (list car1))
+          (append cdrs (list cdr1))))))
+
+(define (map proc . lists)
+  (if (null? lists)
+      (apply proc)
+      (if (null? (car lists))
+        '()
+        (let* ((unz (apply unzip1-with-cdr lists))
+               (cars (car unz))
+               (cdrs (cdr unz)))
+          (cons (apply proc cars) (apply map (cons proc cdrs)))))))
+
+(define (for-each proc . lists)
+  (if (null? lists)
+      (apply proc)
+      (if (null? (car lists))
+        #t
+        (let* ((unz (apply unzip1-with-cdr lists))
+               (cars (car unz))
+               (cdrs (cdr unz)))
+          (apply proc cars) (apply map (cons proc cdrs))))))
+
+(define (list-tail x k)
+    (if (zero? k)
+        x
+        (list-tail (cdr x) (- k 1))))
+
+(define (list-ref x k)
+    (car (list-tail x k)))
+
+(define (last-pair x)
+    (if (pair? (cdr x))
+        (last-pair (cdr x))
+        x))
+
+(define (head stream) (car stream))
+
+(define (tail stream) (force (cdr stream)))
+
+(define (vector-equal? x y)
+     (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
+          (let ((n (vector-length x)))
+               (let loop ((i 0))
+                    (if (= i n)
+                         #t
+                         (and (equal? (vector-ref x i) (vector-ref y i))
+                              (loop (succ i))))))))
+
+(define (list->vector x)
+     (apply vector x))
+
+(define (vector-fill! v e)
+     (let ((n (vector-length v)))
+          (let loop ((i 0))
+               (if (= i n)
+                    v
+                    (begin (vector-set! v i e) (loop (succ i)))))))
+
+(define (vector->list v)
+     (let loop ((n (pred (vector-length v))) (l '()))
+          (if (= n -1)
+               l
+               (loop (pred n) (cons (vector-ref v n) l)))))
+
+;; The following quasiquote macro is due to Eric S. Tiedemann.
+;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
+;;
+;; Subsequently modified to handle vectors: D. Souflis
+
+(macro
+ quasiquote
+ (lambda (l)
+   (define (mcons f l r)
+     (if (and (pair? r)
+              (eq? (car r) 'quote)
+              (eq? (car (cdr r)) (cdr f))
+              (pair? l)
+              (eq? (car l) 'quote)
+              (eq? (car (cdr l)) (car f)))
+         (if (or (procedure? f) (number? f) (string? f))
+               f
+               (list 'quote f))
+         (if (eqv? l vector)
+               (apply l (eval r))
+               (list 'cons l r)
+               )))
+   (define (mappend f l r)
+     (if (or (null? (cdr f))
+             (and (pair? r)
+                  (eq? (car r) 'quote)
+                  (eq? (car (cdr r)) '())))
+         l
+         (list 'append l r)))
+   (define (foo level form)
+     (cond ((not (pair? form))
+               (if (or (procedure? form) (number? form) (string? form))
+                    form
+                    (list 'quote form))
+               )
+           ((eq? 'quasiquote (car form))
+            (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
+           (#t (if (zero? level)
+                   (cond ((eq? (car form) 'unquote) (car (cdr form)))
+                         ((eq? (car form) 'unquote-splicing)
+                          (error "Unquote-splicing wasn't in a list:"
+                                 form))
+                         ((and (pair? (car form))
+                               (eq? (car (car form)) 'unquote-splicing))
+                          (mappend form (car (cdr (car form)))
+                                   (foo level (cdr form))))
+                         (#t (mcons form (foo level (car form))
+                                         (foo level (cdr form)))))
+                   (cond ((eq? (car form) 'unquote)
+                          (mcons form ''unquote (foo (- level 1)
+                                                     (cdr form))))
+                         ((eq? (car form) 'unquote-splicing)
+                          (mcons form ''unquote-splicing
+                                      (foo (- level 1) (cdr form))))
+                         (#t (mcons form (foo level (car form))
+                                         (foo level (cdr form)))))))))
+   (foo 0 (car (cdr l)))))
+
+;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
+(define (shared-tail x y)
+   (let ((len-x (length x))
+         (len-y (length y)))
+      (define (shared-tail-helper x y)
+         (if
+            (eq? x y)
+            x
+            (shared-tail-helper (cdr x) (cdr y))))
+
+      (cond
+         ((> len-x len-y)
+            (shared-tail-helper
+               (list-tail x (- len-x len-y))
+               y))
+         ((< len-x len-y)
+            (shared-tail-helper
+               x
+               (list-tail y (- len-y len-x))))
+         (#t (shared-tail-helper x y)))))
+
+;;;;;Dynamic-wind by Tom Breton (Tehom)
+
+;;Guarded because we must only eval this once, because doing so
+;;redefines call/cc in terms of old call/cc
+(unless (defined? 'dynamic-wind)
+   (let
+      ;;These functions are defined in the context of a private list of
+      ;;pairs of before/after procs.
+      (  (*active-windings* '())
+         ;;We'll define some functions into the larger environment, so
+         ;;we need to know it.
+         (outer-env (current-environment)))
+
+      ;;Poor-man's structure operations
+      (define before-func car)
+      (define after-func  cdr)
+      (define make-winding cons)
+
+      ;;Manage active windings
+      (define (activate-winding! new)
+         ((before-func new))
+         (set! *active-windings* (cons new *active-windings*)))
+      (define (deactivate-top-winding!)
+         (let ((old-top (car *active-windings*)))
+            ;;Remove it from the list first so it's not active during its
+            ;;own exit.
+            (set! *active-windings* (cdr *active-windings*))
+            ((after-func old-top))))
+
+      (define (set-active-windings! new-ws)
+         (unless (eq? new-ws *active-windings*)
+            (let ((shared (shared-tail new-ws *active-windings*)))
+
+               ;;Define the looping functions.
+               ;;Exit the old list.  Do deeper ones last.  Don't do
+               ;;any shared ones.
+               (define (pop-many)
+                  (unless (eq? *active-windings* shared)
+                     (deactivate-top-winding!)
+                     (pop-many)))
+               ;;Enter the new list.  Do deeper ones first so that the
+               ;;deeper windings will already be active.  Don't do any
+               ;;shared ones.
+               (define (push-many new-ws)
+                  (unless (eq? new-ws shared)
+                     (push-many (cdr new-ws))
+                     (activate-winding! (car new-ws))))
+
+               ;;Do it.
+               (pop-many)
+               (push-many new-ws))))
+
+      ;;The definitions themselves.
+      (eval
+         `(define call-with-current-continuation
+             ;;It internally uses the built-in call/cc, so capture it.
+             ,(let ((old-c/cc call-with-current-continuation))
+                 (lambda (func)
+                    ;;Use old call/cc to get the continuation.
+                    (old-c/cc
+                       (lambda (continuation)
+                          ;;Call func with not the continuation itself
+                          ;;but a procedure that adjusts the active
+                          ;;windings to what they were when we made
+                          ;;this, and only then calls the
+                          ;;continuation.
+                          (func
+                             (let ((current-ws *active-windings*))
+                                (lambda (x)
+                                   (set-active-windings! current-ws)
+                                   (continuation x)))))))))
+         outer-env)
+      ;;We can't just say "define (dynamic-wind before thunk after)"
+      ;;because the lambda it's defined to lives in this environment,
+      ;;not in the global environment.
+      (eval
+         `(define dynamic-wind
+             ,(lambda (before thunk after)
+                 ;;Make a new winding
+                 (activate-winding! (make-winding before after))
+                 (let ((result (thunk)))
+                    ;;Get rid of the new winding.
+                    (deactivate-top-winding!)
+                    ;;The return value is that of thunk.
+                    result)))
+         outer-env)))
+
+(define call/cc call-with-current-continuation)
+
+
+;;;;; atom? and equal? written by a.k
+
+;;;; atom?
+(define (atom? x)
+  (not (pair? x)))
+
+;;;;    equal?
+(define (equal? x y)
+     (cond
+          ((pair? x)
+               (and (pair? y)
+                    (equal? (car x) (car y))
+                    (equal? (cdr x) (cdr y))))
+          ((vector? x)
+               (and (vector? y) (vector-equal? x y)))
+          ((string? x)
+               (and (string? y) (string=? x y)))
+          (else (eqv? x y))))
+
+;;;; (do ((var init inc) ...) (endtest result ...) body ...)
+;;
+(macro do
+  (lambda (do-macro)
+    (apply (lambda (do vars endtest . body)
+             (let ((do-loop (gensym)))
+               `(letrec ((,do-loop
+                           (lambda ,(map (lambda (x)
+                                           (if (pair? x) (car x) x))
+                                      `,vars)
+                             (if ,(car endtest)
+                               (begin ,@(cdr endtest))
+                               (begin
+                                 ,@body
+                                 (,do-loop
+                                   ,@(map (lambda (x)
+                                            (cond
+                                              ((not (pair? x)) x)
+                                              ((< (length x) 3) (car x))
+                                              (else (car (cdr (cdr x))))))
+                                       `,vars)))))))
+                  (,do-loop
+                    ,@(map (lambda (x)
+                             (if (and (pair? x) (cdr x))
+                               (car (cdr x))
+                               '()))
+                        `,vars)))))
+      do-macro)))
+
+;;;; generic-member
+(define (generic-member cmp obj lst)
+  (cond
+    ((null? lst) #f)
+    ((cmp obj (car lst)) lst)
+    (else (generic-member cmp obj (cdr lst)))))
+
+(define (memq obj lst)
+     (generic-member eq? obj lst))
+(define (memv obj lst)
+     (generic-member eqv? obj lst))
+(define (member obj lst)
+     (generic-member equal? obj lst))
+
+;;;; generic-assoc
+(define (generic-assoc cmp obj alst)
+     (cond
+          ((null? alst) #f)
+          ((cmp obj (caar alst)) (car alst))
+          (else (generic-assoc cmp obj (cdr alst)))))
+
+(define (assq obj alst)
+     (generic-assoc eq? obj alst))
+(define (assv obj alst)
+     (generic-assoc eqv? obj alst))
+(define (assoc obj alst)
+     (generic-assoc equal? obj alst))
+
+(define (acons x y z) (cons (cons x y) z))
+
+;;;; Handy for imperative programs
+;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
+(macro (define-with-return form)
+     `(define ,(cadr form)
+          (call/cc (lambda (return) ,@(cddr form)))))
+
+;;;; Simple exception handling
+;
+;    Exceptions are caught as follows:
+;
+;         (catch (do-something to-recover and-return meaningful-value)
+;              (if-something goes-wrong)
+;              (with-these calls))
+;
+;    "Catch" establishes a scope spanning multiple call-frames
+;    until another "catch" is encountered.
+;
+;    Exceptions are thrown with:
+;
+;         (throw "message")
+;
+;    If used outside a (catch ...), reverts to (error "message)
+
+(define *handlers* (list))
+
+(define (push-handler proc)
+     (set! *handlers* (cons proc *handlers*)))
+
+(define (pop-handler)
+     (let ((h (car *handlers*)))
+          (set! *handlers* (cdr *handlers*))
+          h))
+
+(define (more-handlers?)
+     (pair? *handlers*))
+
+(define (throw . x)
+     (if (more-handlers?)
+          (apply (pop-handler))
+          (apply error x)))
+
+(macro (catch form)
+     (let ((label (gensym)))
+          `(call/cc (lambda (exit)
+               (push-handler (lambda () (exit ,(cadr form))))
+               (let ((,label (begin ,@(cddr form))))
+                    (pop-handler)
+                    ,label)))))
+
+(define *error-hook* throw)
+
+
+;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
+
+(macro (make-environment form)
+     `(apply (lambda ()
+               ,@(cdr form)
+               (current-environment))))
+
+(define-macro (eval-polymorphic x . envl)
+  (display envl)
+  (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
+         (xval (eval x env)))
+    (if (closure? xval)
+      (make-closure (get-closure-code xval) env)
+      xval)))
+
+; Redefine this if you install another package infrastructure
+; Also redefine 'package'
+(define *colon-hook* eval)
+
+;;;;; I/O
+
+(define (input-output-port? p)
+     (and (input-port? p) (output-port? p)))
+
+(define (close-port p)
+     (cond
+          ((input-output-port? p) (close-input-port p) (close-output-port p))
+          ((input-port? p) (close-input-port p))
+          ((output-port? p) (close-output-port p))
+          (else (throw "Not a port" p))))
+
+(define (call-with-input-file s p)
+     (let ((inport (open-input-file s)))
+          (if (eq? inport #f)
+               #f
+               (let ((res (p inport)))
+                    (close-input-port inport)
+                    res))))
+
+(define (call-with-output-file s p)
+     (let ((outport (open-output-file s)))
+          (if (eq? outport #f)
+               #f
+               (let ((res (p outport)))
+                    (close-output-port outport)
+                    res))))
+
+(define (with-input-from-file s p)
+     (let ((inport (open-input-file s)))
+          (if (eq? inport #f)
+               #f
+               (let ((prev-inport (current-input-port)))
+                    (set-input-port inport)
+                    (let ((res (p)))
+                         (close-input-port inport)
+                         (set-input-port prev-inport)
+                         res)))))
+
+(define (with-output-to-file s p)
+     (let ((outport (open-output-file s)))
+          (if (eq? outport #f)
+               #f
+               (let ((prev-outport (current-output-port)))
+                    (set-output-port outport)
+                    (let ((res (p)))
+                         (close-output-port outport)
+                         (set-output-port prev-outport)
+                         res)))))
+
+(define (with-input-output-from-to-files si so p)
+     (let ((inport (open-input-file si))
+           (outport (open-input-file so)))
+          (if (not (and inport outport))
+               (begin
+                    (close-input-port inport)
+                    (close-output-port outport)
+                    #f)
+               (let ((prev-inport (current-input-port))
+                     (prev-outport (current-output-port)))
+                    (set-input-port inport)
+                    (set-output-port outport)
+                    (let ((res (p)))
+                         (close-input-port inport)
+                         (close-output-port outport)
+                         (set-input-port prev-inport)
+                         (set-output-port prev-outport)
+                         res)))))
+
+; Random number generator (maximum cycle)
+(define *seed* 1)
+(define (random-next)
+     (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
+          (set! *seed*
+               (-   (* a (- *seed*
+                         (* (quotient *seed* q) q)))
+                    (* (quotient *seed* q) r)))
+          (if (< *seed* 0) (set! *seed* (+ *seed* m)))
+          *seed*))
+;; SRFI-0
+;; COND-EXPAND
+;; Implemented as a macro
+(define *features* '(srfi-0 tinyscheme))
+
+(define-macro (cond-expand . cond-action-list)
+  (cond-expand-runtime cond-action-list))
+
+(define (cond-expand-runtime cond-action-list)
+  (if (null? cond-action-list)
+      #t
+      (if (cond-eval (caar cond-action-list))
+          `(begin ,@(cdar cond-action-list))
+          (cond-expand-runtime (cdr cond-action-list)))))
+
+(define (cond-eval-and cond-list)
+  (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
+
+(define (cond-eval-or cond-list)
+  (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
+
+(define (cond-eval condition)
+  (cond
+    ((symbol? condition)
+       (if (member condition *features*) #t #f))
+    ((eq? condition #t) #t)
+    ((eq? condition #f) #f)
+    (else (case (car condition)
+            ((and) (cond-eval-and (cdr condition)))
+            ((or) (cond-eval-or (cdr condition)))
+            ((not) (if (not (null? (cddr condition)))
+                     (error "cond-expand : 'not' takes 1 argument")
+                     (not (cond-eval (cadr condition)))))
+            (else (error "cond-expand : unknown operator" (car condition)))))))
+
+(gc-verbose #f)

plug-ins/script-fu/libscriptfu/tinyscheme/meson.build

@@ -0,0 +1,18 @@
+
+# No include_directories('.') here; use libscriptfuInclude 
+
+scriptfu_tinyscheme = static_library('scriptfu-tinyscheme',
+  'scheme.c',
+  include_directories: [ rootInclude, ],
+  dependencies: [
+    glib,
+  ],
+  c_args: [
+    '-DSTANDALONE=0',
+    '-DUSE_ASCII_NAMES=0',
+    '-DUSE_INTERFACE=1',
+    '-DUSE_MATH=1',
+    '-DUSE_STRLWR=0',
+  ],
+  install: false,
+)

plug-ins/script-fu/libscriptfu/tinyscheme/opdefines.h

@@ -0,0 +1,202 @@
+    _OP_DEF(opexe_0, "load",                           1,  1,       TST_STRING,                      OP_LOAD             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_T0LVL            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_T1LVL            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_READ_INTERNAL    )
+    _OP_DEF(opexe_0, "gensym",                         0,  0,       0,                               OP_GENSYM           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_VALUEPRINT       )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_EVAL             )
+#if USE_TRACING
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_REAL_EVAL        )
+#endif
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_E0ARGS           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_E1ARGS           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_APPLY            )
+#if USE_TRACING
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_REAL_APPLY       )
+    _OP_DEF(opexe_0, "tracing",                        1,  1,       TST_NATURAL,                     OP_TRACING          )
+#endif
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DOMACRO          )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA1          )
+    _OP_DEF(opexe_0, "make-closure",                   1,  2,       TST_PAIR TST_ENVIRONMENT,        OP_MKCLOSURE        )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_QUOTE            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF0             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF1             )
+    _OP_DEF(opexe_0, "defined?",                       1,  2,       TST_SYMBOL TST_ENVIRONMENT,      OP_DEFP             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_BEGIN            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_IF0              )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_IF1              )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_SET0             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_SET1             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET0             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET1             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET2             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET0AST          )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET1AST          )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET2AST          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET0REC          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET1REC          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET2REC          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_COND0            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_COND1            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_DELAY            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_AND0             )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_AND1             )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_OR0              )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_OR1              )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_C0STREAM         )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_C1STREAM         )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_MACRO0           )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_MACRO1           )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE0            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE1            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE2            )
+    _OP_DEF(opexe_1, "eval",                           1,  2,       TST_ANY TST_ENVIRONMENT,         OP_PEVAL            )
+    _OP_DEF(opexe_1, "apply",                          1,  INF_ARG, TST_NONE,                        OP_PAPPLY           )
+    _OP_DEF(opexe_1, "call-with-current-continuation", 1,  1,       TST_NONE,                        OP_CONTINUATION     )
+#if USE_MATH
+    _OP_DEF(opexe_2, "inexact->exact",                 1,  1,       TST_NUMBER,                      OP_INEX2EX          )
+    _OP_DEF(opexe_2, "exp",                            1,  1,       TST_NUMBER,                      OP_EXP              )
+    _OP_DEF(opexe_2, "log",                            1,  1,       TST_NUMBER,                      OP_LOG              )
+    _OP_DEF(opexe_2, "sin",                            1,  1,       TST_NUMBER,                      OP_SIN              )
+    _OP_DEF(opexe_2, "cos",                            1,  1,       TST_NUMBER,                      OP_COS              )
+    _OP_DEF(opexe_2, "tan",                            1,  1,       TST_NUMBER,                      OP_TAN              )
+    _OP_DEF(opexe_2, "asin",                           1,  1,       TST_NUMBER,                      OP_ASIN             )
+    _OP_DEF(opexe_2, "acos",                           1,  1,       TST_NUMBER,                      OP_ACOS             )
+    _OP_DEF(opexe_2, "atan",                           1,  2,       TST_NUMBER,                      OP_ATAN             )
+    _OP_DEF(opexe_2, "sqrt",                           1,  1,       TST_NUMBER,                      OP_SQRT             )
+    _OP_DEF(opexe_2, "expt",                           2,  2,       TST_NUMBER,                      OP_EXPT             )
+    _OP_DEF(opexe_2, "floor",                          1,  1,       TST_NUMBER,                      OP_FLOOR            )
+    _OP_DEF(opexe_2, "ceiling",                        1,  1,       TST_NUMBER,                      OP_CEILING          )
+    _OP_DEF(opexe_2, "truncate",                       1,  1,       TST_NUMBER,                      OP_TRUNCATE         )
+    _OP_DEF(opexe_2, "round",                          1,  1,       TST_NUMBER,                      OP_ROUND            )
+#endif
+    _OP_DEF(opexe_2, "+",                              0,  INF_ARG, TST_NUMBER,                      OP_ADD              )
+    _OP_DEF(opexe_2, "-",                              1,  INF_ARG, TST_NUMBER,                      OP_SUB              )
+    _OP_DEF(opexe_2, "*",                              0,  INF_ARG, TST_NUMBER,                      OP_MUL              )
+    _OP_DEF(opexe_2, "/",                              1,  INF_ARG, TST_NUMBER,                      OP_DIV              )
+    _OP_DEF(opexe_2, "quotient",                       2,  2,       TST_INTEGER,                     OP_INTDIV           )
+    _OP_DEF(opexe_2, "remainder",                      2,  2,       TST_INTEGER,                     OP_REM              )
+    _OP_DEF(opexe_2, "modulo",                         2,  2,       TST_INTEGER,                     OP_MOD              )
+    _OP_DEF(opexe_2, "car",                            1,  1,       TST_PAIR,                        OP_CAR              )
+    _OP_DEF(opexe_2, "cdr",                            1,  1,       TST_PAIR,                        OP_CDR              )
+    _OP_DEF(opexe_2, "cons",                           2,  2,       TST_NONE,                        OP_CONS             )
+    _OP_DEF(opexe_2, "set-car!",                       2,  2,       TST_PAIR TST_ANY,                OP_SETCAR           )
+    _OP_DEF(opexe_2, "set-cdr!",                       2,  2,       TST_PAIR TST_ANY,                OP_SETCDR           )
+    _OP_DEF(opexe_2, "byte->integer",                  1,  1,       TST_BYTE,                        OP_BYTE2INT         )
+    _OP_DEF(opexe_2, "integer->byte",                  1,  1,       TST_NATURAL,                     OP_INT2BYTE         )
+    _OP_DEF(opexe_2, "char->integer",                  1,  1,       TST_CHAR,                        OP_CHAR2INT         )
+    _OP_DEF(opexe_2, "integer->char",                  1,  1,       TST_NATURAL,                     OP_INT2CHAR         )
+    _OP_DEF(opexe_2, "char-upcase",                    1,  1,       TST_CHAR,                        OP_CHARUPCASE       )
+    _OP_DEF(opexe_2, "char-downcase",                  1,  1,       TST_CHAR,                        OP_CHARDNCASE       )
+    _OP_DEF(opexe_2, "symbol->string",                 1,  1,       TST_SYMBOL,                      OP_SYM2STR          )
+    _OP_DEF(opexe_2, "atom->string",                   1,  2,       TST_ANY TST_NATURAL,             OP_ATOM2STR         )
+    _OP_DEF(opexe_2, "string->symbol",                 1,  1,       TST_STRING,                      OP_STR2SYM          )
+    _OP_DEF(opexe_2, "string->atom",                   1,  2,       TST_STRING TST_NATURAL,          OP_STR2ATOM         )
+    _OP_DEF(opexe_2, "make-string",                    1,  2,       TST_NATURAL TST_CHAR,            OP_MKSTRING         )
+    _OP_DEF(opexe_2, "string-length",                  1,  1,       TST_STRING,                      OP_STRLEN           )
+    _OP_DEF(opexe_2, "string-ref",                     2,  2,       TST_STRING TST_NATURAL,          OP_STRREF           )
+    _OP_DEF(opexe_2, "string-set!",                    3,  3,       TST_STRING TST_NATURAL TST_CHAR, OP_STRSET           )
+    _OP_DEF(opexe_2, "string-append",                  0,  INF_ARG, TST_STRING,                      OP_STRAPPEND        )
+    _OP_DEF(opexe_2, "substring",                      2,  3,       TST_STRING TST_NATURAL,          OP_SUBSTR           )
+    _OP_DEF(opexe_2, "vector",                         0,  INF_ARG, TST_NONE,                        OP_VECTOR           )
+    _OP_DEF(opexe_2, "make-vector",                    1,  2,       TST_NATURAL TST_ANY,             OP_MKVECTOR         )
+    _OP_DEF(opexe_2, "vector-length",                  1,  1,       TST_VECTOR,                      OP_VECLEN           )
+    _OP_DEF(opexe_2, "vector-ref",                     2,  2,       TST_VECTOR TST_NATURAL,          OP_VECREF           )
+    _OP_DEF(opexe_2, "vector-set!",                    3,  3,       TST_VECTOR TST_NATURAL TST_ANY,  OP_VECSET           )
+    _OP_DEF(opexe_3, "not",                            1,  1,       TST_NONE,                        OP_NOT              )
+    _OP_DEF(opexe_3, "boolean?",                       1,  1,       TST_NONE,                        OP_BOOLP            )
+    _OP_DEF(opexe_3, "eof-object?",                    1,  1,       TST_NONE,                        OP_EOFOBJP          )
+    _OP_DEF(opexe_3, "null?",                          1,  1,       TST_NONE,                        OP_NULLP            )
+    _OP_DEF(opexe_3, "=",                              2,  INF_ARG, TST_NUMBER,                      OP_NUMEQ            )
+    _OP_DEF(opexe_3, "<",                              2,  INF_ARG, TST_NUMBER,                      OP_LESS             )
+    _OP_DEF(opexe_3, ">",                              2,  INF_ARG, TST_NUMBER,                      OP_GRE              )
+    _OP_DEF(opexe_3, "<=",                             2,  INF_ARG, TST_NUMBER,                      OP_LEQ              )
+    _OP_DEF(opexe_3, ">=",                             2,  INF_ARG, TST_NUMBER,                      OP_GEQ              )
+    _OP_DEF(opexe_3, "symbol?",                        1,  1,       TST_ANY,                         OP_SYMBOLP          )
+    _OP_DEF(opexe_3, "number?",                        1,  1,       TST_ANY,                         OP_NUMBERP          )
+    _OP_DEF(opexe_3, "string?",                        1,  1,       TST_ANY,                         OP_STRINGP          )
+    _OP_DEF(opexe_3, "integer?",                       1,  1,       TST_ANY,                         OP_INTEGERP         )
+    _OP_DEF(opexe_3, "real?",                          1,  1,       TST_ANY,                         OP_REALP            )
+    _OP_DEF(opexe_3, "byte?",                          1,  1,       TST_ANY,                         OP_BYTEP            )
+    _OP_DEF(opexe_3, "char?",                          1,  1,       TST_ANY,                         OP_CHARP            )
+#if USE_CHAR_CLASSIFIERS
+    _OP_DEF(opexe_3, "char-alphabetic?",               1,  1,       TST_CHAR,                        OP_CHARAP           )
+    _OP_DEF(opexe_3, "char-numeric?",                  1,  1,       TST_CHAR,                        OP_CHARNP           )
+    _OP_DEF(opexe_3, "char-whitespace?",               1,  1,       TST_CHAR,                        OP_CHARWP           )
+    _OP_DEF(opexe_3, "char-upper-case?",               1,  1,       TST_CHAR,                        OP_CHARUP           )
+    _OP_DEF(opexe_3, "char-lower-case?",               1,  1,       TST_CHAR,                        OP_CHARLP           )
+#endif
+    _OP_DEF(opexe_3, "port?",                          1,  1,       TST_ANY,                         OP_PORTP            )
+    _OP_DEF(opexe_3, "input-port?",                    1,  1,       TST_ANY,                         OP_INPORTP          )
+    _OP_DEF(opexe_3, "output-port?",                   1,  1,       TST_ANY,                         OP_OUTPORTP         )
+    _OP_DEF(opexe_3, "procedure?",                     1,  1,       TST_ANY,                         OP_PROCP            )
+    _OP_DEF(opexe_3, "pair?",                          1,  1,       TST_ANY,                         OP_PAIRP            )
+    _OP_DEF(opexe_3, "list?",                          1,  1,       TST_ANY,                         OP_LISTP            )
+    _OP_DEF(opexe_3, "environment?",                   1,  1,       TST_ANY,                         OP_ENVP             )
+    _OP_DEF(opexe_3, "vector?",                        1,  1,       TST_ANY,                         OP_VECTORP          )
+    _OP_DEF(opexe_3, "eq?",                            2,  2,       TST_ANY,                         OP_EQ               )
+    _OP_DEF(opexe_3, "eqv?",                           2,  2,       TST_ANY,                         OP_EQV              )
+    _OP_DEF(opexe_4, "force",                          1,  1,       TST_ANY,                         OP_FORCE            )
+    _OP_DEF(opexe_4, 0,                                0,  0,       0,                               OP_SAVE_FORCED      )
+    _OP_DEF(opexe_4, "write",                          1,  2,       TST_ANY TST_OUTPORT,             OP_WRITE            )
+    _OP_DEF(opexe_4, "write-byte",                     1,  2,       TST_BYTE TST_OUTPORT,            OP_WRITE_BYTE       )
+    _OP_DEF(opexe_4, "write-char",                     1,  2,       TST_CHAR TST_OUTPORT,            OP_WRITE_CHAR       )
+    _OP_DEF(opexe_4, "display",                        1,  2,       TST_ANY TST_OUTPORT,             OP_DISPLAY          )
+    _OP_DEF(opexe_4, "newline",                        0,  1,       TST_OUTPORT,                     OP_NEWLINE          )
+    _OP_DEF(opexe_4, "error",                          1,  INF_ARG, TST_NONE,                        OP_ERR0             )
+    _OP_DEF(opexe_4, 0,                                0,  0,       0,                               OP_ERR1             )
+    _OP_DEF(opexe_4, "reverse",                        1,  1,       TST_LIST,                        OP_REVERSE          )
+    _OP_DEF(opexe_4, "list*",                          1,  INF_ARG, TST_NONE,                        OP_LIST_STAR        )
+    _OP_DEF(opexe_4, "append",                         0,  INF_ARG, TST_NONE,                        OP_APPEND           )
+#if USE_PLIST
+    _OP_DEF(opexe_4, "put",                            3,  3,       TST_NONE,                        OP_PUT              )
+    _OP_DEF(opexe_4, "get",                            2,  2,       TST_NONE,                        OP_GET              )
+#endif
+    _OP_DEF(opexe_4, "quit",                           0,  1,       TST_NUMBER,                      OP_QUIT             )
+    _OP_DEF(opexe_4, "gc",                             0,  0,       0,                               OP_GC               )
+    _OP_DEF(opexe_4, "gc-verbose",                     0,  1,       TST_NONE,                        OP_GCVERB           )
+    _OP_DEF(opexe_4, "new-segment",                    0,  1,       TST_NUMBER,                      OP_NEWSEGMENT       )
+    _OP_DEF(opexe_4, "oblist",                         0,  0,       0,                               OP_OBLIST           )
+    _OP_DEF(opexe_4, "current-input-port",             0,  0,       0,                               OP_CURR_INPORT      )
+    _OP_DEF(opexe_4, "current-output-port",            0,  0,       0,                               OP_CURR_OUTPORT     )
+    _OP_DEF(opexe_4, "open-input-file",                1,  1,       TST_STRING,                      OP_OPEN_INFILE      )
+    _OP_DEF(opexe_4, "open-output-file",               1,  1,       TST_STRING,                      OP_OPEN_OUTFILE     )
+    _OP_DEF(opexe_4, "open-input-output-file",         1,  1,       TST_STRING,                      OP_OPEN_INOUTFILE   )
+#if USE_STRING_PORTS
+    _OP_DEF(opexe_4, "open-input-string",              1,  1,       TST_STRING,                      OP_OPEN_INSTRING    )
+    _OP_DEF(opexe_4, "open-input-output-string",       1,  1,       TST_STRING,                      OP_OPEN_INOUTSTRING )
+    _OP_DEF(opexe_4, "open-output-string",             0,  1,       TST_STRING,                      OP_OPEN_OUTSTRING   )
+    _OP_DEF(opexe_4, "get-output-string",              1,  1,       TST_OUTPORT,                     OP_GET_OUTSTRING    )
+#endif
+    _OP_DEF(opexe_4, "close-input-port",               1,  1,       TST_INPORT,                      OP_CLOSE_INPORT     )
+    _OP_DEF(opexe_4, "close-output-port",              1,  1,       TST_OUTPORT,                     OP_CLOSE_OUTPORT    )
+    _OP_DEF(opexe_4, "interaction-environment",        0,  0,       0,                               OP_INT_ENV          )
+    _OP_DEF(opexe_4, "current-environment",            0,  0,       0,                               OP_CURR_ENV         )
+    _OP_DEF(opexe_5, "read",                           0,  1,       TST_INPORT,                      OP_READ             )
+    _OP_DEF(opexe_5, "read-char",                      0,  1,       TST_INPORT,                      OP_READ_CHAR        )
+    _OP_DEF(opexe_5, "peek-char",                      0,  1,       TST_INPORT,                      OP_PEEK_CHAR        )
+    _OP_DEF(opexe_5, "char-ready?",                    0,  1,       TST_INPORT,                      OP_CHAR_READY       )
+    _OP_DEF(opexe_5, "read-byte",                      0,  1,       TST_INPORT,                      OP_READ_BYTE        )
+    _OP_DEF(opexe_5, "peek-byte",                      0,  1,       TST_INPORT,                      OP_PEEK_BYTE        )
+    _OP_DEF(opexe_5, "byte-ready?",                    0,  1,       TST_INPORT,                      OP_BYTE_READY       )
+    _OP_DEF(opexe_5, "set-input-port",                 1,  1,       TST_INPORT,                      OP_SET_INPORT       )
+    _OP_DEF(opexe_5, "set-output-port",                1,  1,       TST_OUTPORT,                     OP_SET_OUTPORT      )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDSEXPR          )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDLIST           )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDDOT            )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQUOTE          )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQQUOTE         )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQQUOTEVEC      )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDUNQUOTE        )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDUQTSP          )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDVEC            )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_P0LIST           )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_P1LIST           )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_PVECFROM         )
+    _OP_DEF(opexe_6, "length",                         1,  1,       TST_LIST,                        OP_LIST_LENGTH      )
+    _OP_DEF(opexe_6, "assq",                           2,  2,       TST_NONE,                        OP_ASSQ             )
+    _OP_DEF(opexe_6, "get-closure-code",               1,  1,       TST_NONE,                        OP_GET_CLOSURE      )
+    _OP_DEF(opexe_6, "closure?",                       1,  1,       TST_NONE,                        OP_CLOSUREP         )
+    _OP_DEF(opexe_6, "macro?",                         1,  1,       TST_NONE,                        OP_MACROP           )
+#undef _OP_DEF

plug-ins/script-fu/libscriptfu/tinyscheme/scheme-private.h

@@ -0,0 +1,226 @@
+/* scheme-private.h */
+
+#ifndef _SCHEME_PRIVATE_H
+#define _SCHEME_PRIVATE_H
+
+#include "scheme.h"
+/*------------------ Ugly internals -----------------------------------*/
+/*------------------ Of interest only to FFI users --------------------*/
+
+enum scheme_port_kind {
+  port_free=0,
+  port_file=1,
+  port_string=2,
+  port_srfi6=4,
+  port_input=16,
+  port_output=32,
+  port_saw_EOF=64
+};
+
+typedef struct port {
+  unsigned char kind;
+  union {
+    struct {
+      FILE *file;
+      int closeit;
+#if SHOW_ERROR_LINE
+      int curr_line;
+      char *filename;
+#endif
+    } stdio;
+    struct {
+      char *start;
+      char *past_the_end;
+      char *curr;
+    } string;
+  } rep;
+} port;
+
+/* cell structure */
+struct cell {
+  unsigned int _flag;
+  union {
+    struct {
+      char   *_svalue;
+      int   _length;
+    } _string;
+    num _number;
+    port *_port;
+    foreign_func _ff;
+    struct {
+      struct cell *_car;
+      struct cell *_cdr;
+    } _cons;
+  } _object;
+};
+
+struct scheme {
+/* arrays for segments */
+func_alloc malloc;
+func_dealloc free;
+
+/* return code */
+int retcode;
+int tracing;
+
+
+#ifndef CELL_SEGSIZE
+#define CELL_SEGSIZE    25000 /* # of cells in one segment */
+#endif
+#ifndef CELL_NSEGMENT
+#define CELL_NSEGMENT   50    /* # of segments for cells */
+#endif
+char *alloc_seg[CELL_NSEGMENT];
+pointer cell_seg[CELL_NSEGMENT];
+int     last_cell_seg;
+
+/* We use 5 registers. */
+pointer args;            /* register for arguments of function */
+pointer envir;           /* stack register for current environment */
+pointer code;            /* register for current code */
+pointer dump;            /* stack register for next evaluation */
+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 */
+
+struct cell _sink;
+pointer sink;            /* when mem. alloc. fails */
+struct cell _NIL;
+pointer NIL;             /* special cell representing empty cell */
+struct cell _HASHT;
+pointer T;               /* special cell representing #t */
+struct cell _HASHF;
+pointer F;               /* special cell representing #f */
+struct cell _EOF_OBJ;
+pointer EOF_OBJ;         /* special cell representing end-of-file object */
+pointer oblist;          /* pointer to symbol table */
+pointer global_env;      /* pointer to global environment */
+
+pointer c_nest;          /* stack for nested calls from C */
+
+/* global pointers to special symbols */
+pointer LAMBDA;          /* pointer to syntax lambda */
+pointer QUOTE;           /* pointer to syntax quote */
+
+pointer QQUOTE;          /* pointer to symbol quasiquote */
+pointer UNQUOTE;         /* pointer to symbol unquote */
+pointer UNQUOTESP;       /* pointer to symbol unquote-splicing */
+pointer FEED_TO;         /* => */
+pointer COLON_HOOK;      /* *colon-hook* */
+pointer ERROR_HOOK;      /* *error-hook* */
+pointer SHARP_HOOK;      /* *sharp-hook* */
+pointer COMPILE_HOOK;    /* *compile-hook* */
+
+pointer free_cell;       /* pointer to top of free cells */
+long    fcells;          /* # of free cells */
+
+pointer inport;
+pointer outport;
+pointer save_inport;
+pointer loadport;
+
+#ifndef MAXFIL
+#define MAXFIL 64
+#endif
+port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
+int nesting_stack[MAXFIL];
+int file_i;
+int nesting;
+
+char    gc_verbose;      /* if gc_verbose is not zero, print gc status */
+char    no_memory;       /* Whether mem. alloc. has failed */
+
+#ifndef LINESIZE
+#define LINESIZE 1024
+#endif
+char    linebuff[LINESIZE];
+#ifndef STRBUFFSIZE
+#define STRBUFFSIZE 1024
+#endif
+char    strbuff[STRBUFFSIZE];
+
+FILE *tmpfp;
+int tok;
+int print_flag;
+pointer value;
+int op;
+
+void *ext_data;      /* For the benefit of foreign functions */
+long gensym_cnt;
+
+struct scheme_interface *vptr;
+void *dump_base;     /* pointer to base of allocated dump stack */
+int dump_size;       /* number of frames allocated for dump stack */
+};
+
+/* operator code */
+enum scheme_opcodes {
+#define _OP_DEF(A,B,C,D,E,OP) OP,
+#include "opdefines.h"
+  OP_MAXDEFINED
+};
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define cons(sc,a,b) _cons(sc,a,b,0)
+#define immutable_cons(sc,a,b) _cons(sc,a,b,1)
+
+int is_string(pointer p);
+char *string_value(pointer p);
+int is_number(pointer p);
+num nvalue(pointer p);
+long ivalue(pointer p);
+double rvalue(pointer p);
+int is_integer(pointer p);
+int is_real(pointer p);
+int is_byte (pointer p);
+int is_character(pointer p);
+int string_length(pointer p);
+guint8 bytevalue (pointer p);
+gunichar charvalue(pointer p);
+int is_vector(pointer p);
+
+int is_port(pointer p);
+int is_inport(pointer p);
+int is_outport(pointer p);
+
+int is_pair(pointer p);
+pointer pair_car(pointer p);
+pointer pair_cdr(pointer p);
+pointer set_car(pointer p, pointer q);
+pointer set_cdr(pointer p, pointer q);
+
+int is_symbol(pointer p);
+char *symname(pointer p);
+char *symkey(pointer p);
+int hasprop(pointer p);
+
+int is_syntax(pointer p);
+int is_proc(pointer p);
+int is_foreign(pointer p);
+char *syntaxname(pointer p);
+int is_closure(pointer p);
+int is_macro(pointer p);
+pointer closure_code(pointer p);
+pointer closure_env(pointer p);
+
+int is_continuation(pointer p);
+int is_promise(pointer p);
+int is_environment(pointer p);
+int is_immutable(pointer p);
+void setimmutable(pointer p);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/

plug-ins/script-fu/libscriptfu/tinyscheme/scheme.h

@@ -0,0 +1,277 @@
+/* SCHEME.H */
+
+#ifndef _SCHEME_H
+#define _SCHEME_H
+
+#include <stdio.h>
+#include <glib.h>
+#include <glib/gstdio.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * Default values for #define'd symbols
+ */
+#ifndef STANDALONE       /* If used as standalone interpreter */
+# define STANDALONE 1
+#endif
+
+#ifndef _MSC_VER
+# ifndef USE_STRLWR
+#   define USE_STRLWR 1
+# endif
+# define SCHEME_EXPORT extern
+#else
+# define USE_STRLWR 0
+# ifdef _SCHEME_SOURCE
+#  define SCHEME_EXPORT __declspec(dllexport)
+# else
+#  define SCHEME_EXPORT __declspec(dllimport)
+# endif
+#endif
+
+#if USE_NO_FEATURES
+# define USE_MATH 0
+# define USE_CHAR_CLASSIFIERS 0
+# define USE_ASCII_NAMES 0
+# define USE_STRING_PORTS 0
+# define USE_ERROR_HOOK 0
+# define USE_TRACING 0
+# define USE_COLON_HOOK 0
+# define USE_DL 0
+# define USE_PLIST 0
+#endif
+
+/*
+ * Leave it defined if you want continuations, and also for the Sharp Zaurus.
+ * Undefine it if you only care about faster speed and not strict Scheme compatibility.
+ */
+#define USE_SCHEME_STACK
+
+#if USE_DL
+# define USE_INTERFACE 1
+#endif
+
+
+#ifndef USE_MATH         /* If math support is needed */
+# define USE_MATH 1
+#endif
+
+#ifndef USE_CHAR_CLASSIFIERS  /* If char classifiers are needed */
+# define USE_CHAR_CLASSIFIERS 1
+#endif
+
+#ifndef USE_ASCII_NAMES  /* If extended escaped characters are needed */
+# define USE_ASCII_NAMES 1
+#endif
+
+#ifndef USE_STRING_PORTS      /* Enable string ports */
+# define USE_STRING_PORTS 1
+#endif
+
+#ifndef USE_TRACING
+#define USE_TRACING 1
+#endif
+
+#ifndef USE_PLIST
+# define USE_PLIST 0
+#endif
+
+/* To force system errors through user-defined error handling (see *error-hook*) */
+#ifndef USE_ERROR_HOOK
+# define USE_ERROR_HOOK 1
+#endif
+
+#ifndef USE_COLON_HOOK   /* Enable qualified qualifier */
+# define USE_COLON_HOOK 1
+#endif
+
+#ifndef USE_STRLWR
+# define USE_STRLWR 1
+#endif
+
+#ifndef STDIO_ADDS_CR    /* Define if DOS/Windows */
+# define STDIO_ADDS_CR 0
+#endif
+
+#ifndef INLINE
+# define INLINE
+#endif
+
+#ifndef USE_INTERFACE
+# define USE_INTERFACE 0
+#endif
+
+#ifndef SHOW_ERROR_LINE   /* Show error line in file */
+# define SHOW_ERROR_LINE 1
+#endif
+
+typedef struct scheme scheme;
+typedef struct cell *pointer;
+
+typedef void * (*func_alloc)(size_t);
+typedef void (*func_dealloc)(void *);
+
+/* num, for generic arithmetic */
+typedef struct num {
+     char is_fixnum;
+     union {
+          long ivalue;
+          double rvalue;
+     } value;
+} num;
+
+#if !STANDALONE
+
+typedef enum { TS_OUTPUT_NORMAL, TS_OUTPUT_ERROR } TsOutputType;
+
+typedef void (* ts_output_func)       (TsOutputType    type,
+                                       const char     *string,
+                                       int             len,
+                                       gpointer        data);
+
+SCHEME_EXPORT void ts_register_output_func (ts_output_func  func,
+                                            gpointer        user_data);
+SCHEME_EXPORT void ts_output_string        (TsOutputType    type,
+                                            const char     *string,
+                                            int             len);
+#endif
+
+SCHEME_EXPORT scheme *scheme_init_new(void);
+SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free);
+SCHEME_EXPORT int scheme_init(scheme *sc);
+SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc);
+SCHEME_EXPORT void scheme_deinit(scheme *sc);
+SCHEME_EXPORT void scheme_set_input_port_file(scheme *sc, FILE *fin);
+void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end);
+SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin);
+void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end);
+SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin);
+SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename);
+SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd);
+SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname);
+SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args);
+SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj);
+void scheme_set_external_data(scheme *sc, void *p);
+SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value);
+
+typedef pointer (*foreign_func)(scheme *, pointer);
+
+pointer _cons(scheme *sc, pointer a, pointer b, int immutable);
+pointer mk_integer(scheme *sc, long num);
+pointer mk_real(scheme *sc, double num);
+pointer mk_symbol(scheme *sc, const char *name);
+pointer gensym(scheme *sc);
+pointer mk_string(scheme *sc, const char *str);
+pointer mk_counted_string(scheme *sc, const char *str, int len);
+pointer mk_empty_string(scheme *sc, int len, gunichar fill);
+pointer mk_byte (scheme *sc, guint8 b);
+pointer mk_character(scheme *sc, gunichar c);
+pointer mk_foreign_func(scheme *sc, foreign_func f);
+void    putcharacter(scheme *sc, gunichar c);
+void    putstr(scheme *sc, const char *s);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
+
+SCHEME_EXPORT pointer foreign_error (scheme *sc, const char *s, pointer a);
+
+#if USE_INTERFACE
+struct scheme_interface {
+  void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value);
+  pointer (*cons)(scheme *sc, pointer a, pointer b);
+  pointer (*immutable_cons)(scheme *sc, pointer a, pointer b);
+  pointer (*reserve_cells)(scheme *sc, int n);
+  pointer (*mk_integer)(scheme *sc, long num);
+  pointer (*mk_real)(scheme *sc, double num);
+  pointer (*mk_symbol)(scheme *sc, const char *name);
+  pointer (*gensym)(scheme *sc);
+  pointer (*mk_string)(scheme *sc, const char *str);
+  pointer (*mk_counted_string)(scheme *sc, const char *str, int len);
+  pointer (*mk_byte)(scheme *sc, guint8 b);
+  pointer (*mk_character)(scheme *sc, gunichar c);
+  pointer (*mk_vector)(scheme *sc, int len);
+  pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
+  pointer (*mk_closure)(scheme *sc, pointer c, pointer e);
+  void (*putstr)(scheme *sc, const char *s);
+  void (*putcharacter)(scheme *sc, gunichar c);
+
+  int (*is_string)(pointer p);
+  int (*string_length)(pointer p);
+  char *(*string_value)(pointer p);
+  int (*is_number)(pointer p);
+  num (*nvalue)(pointer p);
+  long (*ivalue)(pointer p);
+  double (*rvalue)(pointer p);
+  int (*is_integer)(pointer p);
+  int (*is_real)(pointer p);
+  int (*is_byte)(pointer p);
+  int (*is_character)(pointer p);
+  guint8 (*bytevalue)(pointer p);
+  gunichar (*charvalue)(pointer p);
+  int (*is_list)(scheme *sc, pointer p);
+  int (*is_vector)(pointer p);
+  int (*list_length)(scheme *sc, pointer p);
+  long (*vector_length)(pointer vec);
+  void (*fill_vector)(pointer vec, pointer elem);
+  pointer (*vector_elem)(pointer vec, int ielem);
+  pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel);
+
+  int (*is_port)(pointer p);
+
+  int (*is_pair)(pointer p);
+  pointer (*pair_car)(pointer p);
+  pointer (*pair_cdr)(pointer p);
+  pointer (*set_car)(pointer p, pointer q);
+  pointer (*set_cdr)(pointer p, pointer q);
+
+  int (*is_symbol)(pointer p);
+  char *(*symname)(pointer p);
+
+  int (*is_syntax)(pointer p);
+  int (*is_proc)(pointer p);
+  int (*is_foreign)(pointer p);
+  char *(*syntaxname)(pointer p);
+  int (*is_closure)(pointer p);
+  int (*is_macro)(pointer p);
+  pointer (*closure_code)(pointer p);
+  pointer (*closure_env)(pointer p);
+
+  int (*is_continuation)(pointer p);
+  int (*is_promise)(pointer p);
+  int (*is_environment)(pointer p);
+  int (*is_immutable)(pointer p);
+  void (*setimmutable)(pointer p);
+
+  void (*load_file)(scheme *sc, FILE *fin);
+  void (*load_string)(scheme *sc, const char *input);
+};
+#endif
+
+#if !STANDALONE
+typedef struct scheme_registerable
+{
+  foreign_func  f;
+  const char *  name;
+}
+scheme_registerable;
+
+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr);
+void scheme_register_foreign_func_list(scheme * sc,
+                                      scheme_registerable * list,
+                                      int n);
+
+#endif /* !STANDALONE */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/