243 lines
7.7 KiB
C
243 lines
7.7 KiB
C
|
/* 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);
|
||
|
|
}
|
