/*! \brief Load a Scheme file, catching and logging errors.
* \par Function Description
* Loads \a filename, catching any uncaught errors and logging them.
*
* \bug Most other functions in the libgeda API return TRUE on success
* and FALSE on failure. g_read_file() shouldn't be an exception.
*
* \param toplevel The TOPLEVEL structure.
* \param filename The file name of the Scheme file to load.
* \param err Return location for errors, or NULL.
* \return TRUE on success, FALSE on failure.
*/
gboolean
g_read_file(TOPLEVEL *toplevel, const gchar *filename, GError **err)
{
struct g_read_file_data_t data;
g_return_val_if_fail ((filename != NULL), FALSE);
data.stack = SCM_BOOL_F;
data.filename = scm_from_utf8_string (filename);
data.err = NULL;
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
edascm_dynwind_toplevel (toplevel);
scm_c_catch (SCM_BOOL_T,
(scm_t_catch_body) g_read_file__body, &data,
(scm_t_catch_handler) g_read_file__post_handler, &data,
(scm_t_catch_handler) g_read_file__pre_handler, &data);
scm_dynwind_end ();
/* If no error occurred, indicate success. */
if (data.err == NULL) return TRUE;
g_propagate_error (err, data.err);
return FALSE;
}
/*! \brief Evaluate a gschem action by name.
* \par Function Description
* Evaluates the action named \a action_name, which should be a UTF-8
* string naming a symbol in the user module. If evaluating the
* action fails, prints a message to the log and returns FALSE;
* otherwise, returns TRUE.
*
* \param w_current Current gschem toplevel structure.
* \param action_name Name of action to evaluate.
*
* \return TRUE on success, FALSE on failure.
*/
gboolean
g_action_eval_by_name (GschemToplevel *w_current, const gchar *action_name)
{
SCM s_eval_action_proc;
SCM s_expr;
SCM s_result;
gboolean result;
g_assert (w_current);
g_assert (action_name);
scm_dynwind_begin (0);
g_dynwind_window (w_current);
/* Get the eval-action procedure */
s_eval_action_proc =
scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("gschem action"),
"eval-action!"));
/* Build expression to evaluate */
/* FIXME use SCM_SYMBOL for quote */
s_expr = scm_list_2 (s_eval_action_proc,
scm_list_2 (scm_from_utf8_symbol ("quote"),
scm_from_utf8_symbol (action_name)));
/* Evaluate and get return value */
s_result = g_scm_eval_protected (s_expr, SCM_UNDEFINED);
result = scm_is_true (s_result);
scm_dynwind_end ();
return result;
}
/* We assume that data is actually a char**. The way we return results
* from this function is to malloc a fresh string, and store it in
* this pointer. It is the caller's responsibility to do something
* smart with this freshly allocated storage. the caller can determine
* whether there was an error by initializing the char* passed in to
* NULL. If there is an error, the char string will not be NULL on
* return. */
static SCM
gfec_catcher(void *data, SCM tag, SCM throw_args)
{
SCM func;
SCM result;
const char *msg = NULL;
func = scm_c_eval_string("gnc:error->string");
if (scm_is_procedure(func))
{
result = scm_call_2(func, tag, throw_args);
if (scm_is_string(result))
{
char * str;
scm_dynwind_begin (0);
str = scm_to_locale_string (result);
msg = g_strdup (str);
scm_dynwind_free (str);
scm_dynwind_end ();
}
}
if (msg == NULL)
{
msg = "Error running guile function.";
}
*(char**)data = strdup(msg);
return SCM_UNDEFINED;
}
static SCM call_callable(SCM scm_args)
{
SCM stack = scm_make_stack(SCM_BOOL_T, SCM_EOL);
SCM frame = scm_stack_ref(stack, scm_from_int(0));
SCM proc = scm_frame_procedure(frame);
PyObject *callable = scm_to_pointer(scm_assq_ref(gsubr_alist, proc));
scm_dynwind_begin(0);
PyObject *py_args = scm2py(scm_args);
if (py_args == NULL)
py2scm_exception(); /* does not return */
scm_dynwind_py_decref(py_args);
struct call_callable_data data = { callable, py_args };
PyObject *py_result = (PyObject *)scm_without_guile(
(void *(*)(void *))call_callable1, &data);
if (py_result == NULL)
py2scm_exception(); /* does not return */
scm_dynwind_py_decref(py_result);
SCM scm_result = py2scm(py_result);
scm_dynwind_end();
return scm_result;
}
static SCM scm_nwm_log(SCM msg)
{
scm_dynwind_begin(0);
char *c_msg = scm_to_locale_string(msg);
scm_dynwind_free(c_msg);
fprintf(stderr, "%s\n", c_msg);
scm_dynwind_end();
return SCM_UNSPECIFIED;
}
/*! \brief Callback to handle key events in the drawing area.
* \par Function Description
*
* GTK+ callback function (registered in x_window_setup_draw_events() ) which
* handles key press and release events from the GTK+ system.
*
* \param [in] widget the widget that generated the event
* \param [in] event the event itself
* \param w_current the toplevel environment
* \returns TRUE if the event has been handled.
*/
gboolean
x_event_key (GschemPageView *page_view, GdkEventKey *event, GschemToplevel *w_current)
{
gboolean retval = FALSE;
int pressed;
gboolean special = FALSE;
g_return_val_if_fail (page_view != NULL, FALSE);
#if DEBUG
printf("x_event_key_pressed: Pressed key %i.\n", event->keyval);
#endif
/* update the state of the modifiers */
w_current->ALTKEY = (event->state & GDK_MOD1_MASK) ? 1 : 0;
w_current->SHIFTKEY = (event->state & GDK_SHIFT_MASK) ? 1 : 0;
w_current->CONTROLKEY = (event->state & GDK_CONTROL_MASK) ? 1 : 0;
pressed = (event->type == GDK_KEY_PRESS) ? 1 : 0;
switch (event->keyval) {
case GDK_Alt_L:
case GDK_Alt_R:
w_current->ALTKEY = pressed;
break;
case GDK_Shift_L:
case GDK_Shift_R:
w_current->SHIFTKEY = pressed;
special = TRUE;
break;
case GDK_Control_L:
case GDK_Control_R:
w_current->CONTROLKEY = pressed;
special = TRUE;
break;
}
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
g_dynwind_window (w_current);
/* Special case to update the object being drawn or placed after
* scrolling when Shift or Control were pressed */
if (special) {
x_event_faked_motion (page_view, event);
}
if (pressed)
retval = g_keys_execute (w_current, event) ? TRUE : FALSE;
scm_dynwind_end ();
return retval;
}
static SCM
gdbscm_open_memory (SCM rest)
{
const SCM keywords[] = {
mode_keyword, start_keyword, size_keyword, SCM_BOOL_F
};
char *mode = NULL;
CORE_ADDR start = 0;
CORE_ADDR end;
int mode_arg_pos = -1, start_arg_pos = -1, size_arg_pos = -1;
ULONGEST size;
SCM port;
long mode_bits;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "#sUU", rest,
&mode_arg_pos, &mode,
&start_arg_pos, &start,
&size_arg_pos, &size);
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
if (mode == NULL)
mode = xstrdup ("r");
scm_dynwind_free (mode);
if (size_arg_pos > 0)
{
/* For now be strict about start+size overflowing. If it becomes
a nuisance we can relax things later. */
if (start + size < start)
{
gdbscm_out_of_range_error (FUNC_NAME, 0,
scm_list_2 (gdbscm_scm_from_ulongest (start),
gdbscm_scm_from_ulongest (size)),
_("start+size overflows"));
}
end = start + size;
}
else
end = ~(CORE_ADDR) 0;
mode_bits = ioscm_parse_mode_bits (FUNC_NAME, mode);
port = ioscm_open_port (memory_port_desc, mode_bits);
ioscm_init_memory_port (port, start, end);
scm_dynwind_end ();
/* TODO: Set the file name as "memory-start-end"? */
return port;
}
SCM make_ffmpeg_input(SCM scm_file_name, SCM scm_debug)
{
SCM retval;
struct ffmpeg_t *self;
scm_dynwind_begin(0);
const char *file_name = scm_to_locale_string(scm_file_name);
scm_dynwind_free(file_name);
self = (struct ffmpeg_t *)scm_gc_calloc(sizeof(struct ffmpeg_t), "ffmpeg");
self->video_stream_idx = -1;
self->audio_stream_idx = -1;
SCM_NEWSMOB(retval, ffmpeg_tag, self);
int err;
err = avformat_open_input(&self->fmt_ctx, file_name, NULL, NULL);
if (err < 0) {
ffmpeg_destroy(retval);
scm_misc_error("make-ffmpeg-input", "Error opening file '~a': ~a", scm_list_2(scm_file_name, get_error_text(err)));
};
err = avformat_find_stream_info(self->fmt_ctx, NULL);
if (err < 0) {
ffmpeg_destroy(retval);
scm_misc_error("make-ffmpeg-input", "No stream information in file '~a': ~a", scm_list_2(scm_file_name, get_error_text(err)));
};
// TODO: only open desired streams
// Open video stream
self->video_stream_idx = av_find_best_stream(self->fmt_ctx, AVMEDIA_TYPE_VIDEO, -1, -1, NULL, 0);
if (self->video_stream_idx >= 0)
self->video_codec_ctx = open_decoder(retval, scm_file_name, video_stream(self), "video");
// Open audio stream
self->audio_stream_idx = av_find_best_stream(self->fmt_ctx, AVMEDIA_TYPE_AUDIO, -1, -1, NULL, 0);
if (self->audio_stream_idx >= 0)
self->audio_codec_ctx = open_decoder(retval, scm_file_name, audio_stream(self), "audio");
// Print debug information
if (scm_is_true(scm_debug)) av_dump_format(self->fmt_ctx, 0, file_name, 0);
// Allocate input frames
self->video_target_frame = allocate_frame(retval);
self->audio_target_frame = allocate_frame(retval);
// Initialise data packet
av_init_packet(&self->pkt);
self->pkt.data = NULL;
self->pkt.size = 0;
scm_dynwind_end();
return retval;
}
gchar *gnc_scm_to_locale_string(SCM scm_string)
{
gchar* s;
char * str;
scm_dynwind_begin (0);
str = scm_to_locale_string(scm_string);
/* prevent memory leaks in scm_to_locale_string() per guile manual; see 'http://www.gnu.org/software/guile/manual/html_node/Dynamic-Wind.html#Dynamic-Wind' */
s = g_strdup(str);
scm_dynwind_free (str);
scm_dynwind_end ();
return s;
}
/*! \brief Runs a object hook with a single OBJECT.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with a single-element list containing only \a obj.
*
* \see g_run_hook_object_list()
*
* \param name name of hook to run.
* \param obj #OBJECT argument for hook.
*/
void
g_run_hook_object (GschemToplevel *w_current, const char *name, OBJECT *obj)
{
scm_dynwind_begin (0);
g_dynwind_window (w_current);
SCM expr = scm_list_3 (run_hook_sym,
g_get_hook_by_name (name),
scm_list_2 (list_sym, edascm_from_object (obj)));
g_scm_eval_protected (expr, scm_interaction_environment ());
scm_dynwind_end ();
scm_remember_upto_here_1 (expr);
}
SCM scm_mmr_path_fix(SCM target)
#define FUNC_NAME "path-fix"
{
char *path = NULL;
char *fixed = NULL; // fixed path
char *tmp = NULL;
int path_len = 0;
int bi = 0;
int pi = 0;
SCM ret;
SCM_VALIDATE_STRING(1 ,target);
scm_dynwind_begin(0);
path = scm_to_locale_string(target);
scm_dynwind_free(path);
if(!strstr(path ,"/.."))
{
// no relative path
ret = target;
goto end;
}
path_len = strlen(path);
path_len = path_len>MAX_PATH_LEN? MAX_PATH_LEN : path_len;
fixed = (char *)malloc(path_len+1);
fixed[0] = '\n'; // sentinal
while(get_dir(path ,fixed+1 ,&pi ,&bi))
{}
/* NOTE: The result won't contain '/' at the end,
* because we'll append *path '/' filename* finally.
*/
tmp = fix_prefix(fixed+1);
ret = scm_from_locale_string(tmp);
free(fixed);
fixed = NULL;
tmp = NULL;
end:
scm_dynwind_end();
return ret;
}
static void
load_extension (SCM lib, SCM init)
{
extension_t *head;
scm_i_pthread_mutex_lock (&ext_lock);
head = registered_extensions;
scm_i_pthread_mutex_unlock (&ext_lock);
/* Search the registry. */
if (head != NULL)
{
extension_t *ext;
char *clib, *cinit;
int found = 0;
scm_dynwind_begin (0);
clib = scm_to_locale_string (lib);
scm_dynwind_free (clib);
cinit = scm_to_locale_string (init);
scm_dynwind_free (cinit);
for (ext = head; ext; ext = ext->next)
if ((ext->lib == NULL || !strcmp (ext->lib, clib))
&& !strcmp (ext->init, cinit))
{
ext->func (ext->data);
found = 1;
break;
}
scm_dynwind_end ();
if (found)
return;
}
/* Dynamically link the library. */
#if HAVE_MODULES
scm_dynamic_call (init, scm_dynamic_link (lib));
#else
scm_misc_error ("load-extension",
"extension ~S:~S not registered and dynamic-link disabled",
scm_list_2 (init, lib));
#endif
}
static SCM scm_bind_key(SCM mod_mask, SCM key, SCM proc)
{
xcb_keysym_t keysym;
if (scm_is_true(scm_number_p(key)))
keysym = scm_to_uint32(key);
else if (scm_is_true(scm_string_p(key))) {
scm_dynwind_begin(0);
char *c_key = scm_to_locale_string(key);
scm_dynwind_free(c_key);
keysym = get_keysym(c_key);
scm_dynwind_end();
}
else
return SCM_UNSPECIFIED;
bind_key(scm_to_uint16(mod_mask), keysym, proc);
return SCM_UNSPECIFIED;
}
/*! \brief Evaluates the stroke.
* \par Function Description
* This function transforms the stroke input so far in an action.
*
* It makes use of the guile procedure <B>eval-stroke</B> to evaluate
* the stroke sequence into a possible action. The mouse footprint is
* erased in this function.
*
* It returns 1 if the stroke has been successfully evaluated as an
* action. It returns 0 if libstroke failed to transform the stroke
* or there is no action attached to the stroke.
*
* \param [in] w_current The GschemToplevel object.
* \returns 1 on success, 0 otherwise.
*/
gint
x_stroke_translate_and_execute (GschemToplevel *w_current)
{
gchar sequence[STROKE_MAX_SEQUENCE];
StrokePoint *point;
int min_x, min_y, max_x, max_y;
guint i;
g_assert (stroke_points != NULL);
if (stroke_points->len == 0)
return 0;
point = &g_array_index (stroke_points, StrokePoint, 0);
min_x = max_x = point->x;
min_y = max_y = point->y;
for (i = 1; i < stroke_points->len; i++) {
point = &g_array_index (stroke_points, StrokePoint, i);
min_x = MIN (min_x, point->x);
min_y = MIN (min_y, point->y);
max_x = MAX (max_x, point->x);
max_y = MAX (max_y, point->y);
}
o_invalidate_rect (w_current, min_x, min_y, max_x + 1, max_y + 1);
/* resets length of array */
stroke_points->len = 0;
/* try evaluating stroke */
if (stroke_trans ((char*)&sequence)) {
gchar *guile_string =
g_strdup_printf("(eval-stroke \"%s\")", sequence);
SCM ret;
scm_dynwind_begin ((scm_t_dynwind_flags) 0);
scm_dynwind_unwind_handler (g_free, guile_string, SCM_F_WIND_EXPLICITLY);
ret = g_scm_c_eval_string_protected (guile_string);
scm_dynwind_end ();
return (SCM_NFALSEP (ret));
}
return 0;
}
/*! \brief
* \par Function Description
*
* \param [in] path
* \param [in] name Optional descriptive name for library directory.
* \return SCM_BOOL_T on success, SCM_BOOL_F otherwise.
*/
SCM g_rc_component_library(SCM path, SCM name)
{
gchar *string;
char *temp;
char *namestr = NULL;
SCM_ASSERT (scm_is_string (path), path,
SCM_ARG1, "component-library");
scm_dynwind_begin (0);
if (name != SCM_UNDEFINED) {
SCM_ASSERT (scm_is_string (name), name,
SCM_ARG2, "component-library");
namestr = scm_to_utf8_string (name);
scm_dynwind_free(namestr);
}
/* take care of any shell variables */
temp = scm_to_utf8_string (path);
string = s_expand_env_variables (temp);
scm_dynwind_unwind_handler (g_free, string, SCM_F_WIND_EXPLICITLY);
free (temp);
/* invalid path? */
if (!g_file_test (string, G_FILE_TEST_IS_DIR)) {
fprintf(stderr,
"Invalid path [%s] passed to component-library\n",
string);
scm_dynwind_end();
return SCM_BOOL_F;
}
if (g_path_is_absolute (string)) {
s_clib_add_directory (string, namestr);
} else {
gchar *cwd = g_get_current_dir ();
gchar *temp;
temp = g_build_filename (cwd, string, NULL);
s_clib_add_directory (temp, namestr);
g_free(temp);
g_free(cwd);
}
scm_dynwind_end();
return SCM_BOOL_T;
}
SCM scm_mmr_create_this_path(SCM path ,SCM mode)
#define FUNC_NAME "create-this-path"
{
char *p = NULL;
char *b = NULL;
char *buf = NULL;
SCM ret = SCM_BOOL_F;
int m = 0777;
int len = 0;
int n = 0;
SCM_VALIDATE_STRING(1 ,path);
if(!SCM_UNBNDP(mode))
{
SCM_VALIDATE_NUMBER(2 ,mode);
m = scm_to_int(mode);
}
scm_dynwind_begin(0);
p = scm_to_locale_string(path);
scm_dynwind_free(p);
len = strlen(p);
buf = (char*)malloc(len+1); // Don't forget +1 for '\0'
n = get_path_levels(p ,len);
while(n >= 0)
{
int l = 0;
b = get_parent_path(p ,&n ,len);
l = b-p;
memcpy(buf ,b ,l);
buf[l+1] = '\0';
do_create(buf ,len);
}
free(buf);
buf = NULL;
scm_dynwind_end();
return ret;
}
static void
x_window_invoke_macro (GschemMacroWidget *widget, int response, GschemToplevel *w_current)
{
if (response == GTK_RESPONSE_OK) {
const char *macro = gschem_macro_widget_get_macro_string (widget);
SCM interpreter = scm_list_2(scm_from_utf8_symbol("invoke-macro"),
scm_from_utf8_string(macro));
scm_dynwind_begin (0);
g_dynwind_window (w_current);
g_scm_eval_protected(interpreter, SCM_UNDEFINED);
scm_dynwind_end ();
}
gtk_widget_grab_focus (w_current->drawing_area);
gtk_widget_hide (GTK_WIDGET (widget));
}
/*! \brief Print a representation of a #GschemToplevel smob.
* \par Function Description
* Outputs a string representing the \a smob to a Scheme output
* \a port. The format used is "#<gschem-window b7ef65d0>".
*
* Used internally to Guile.
*/
static int
smob_print (SCM smob, SCM port, scm_print_state *pstate)
{
gchar *hexstring;
scm_puts ("#<gschem-window", port);
scm_dynwind_begin (0);
hexstring = g_strdup_printf (" %zx", SCM_SMOB_DATA (smob));
scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
scm_puts (hexstring, port);
scm_dynwind_end ();
scm_puts (">", port);
/* Non-zero means success */
return 1;
}
static SCM
scm_elev_scm_spline (const char *who,
void elev_scm_spline (size_t new_degree,
size_t degree,
ssize_t stride,
const SCM *spline,
ssize_t result_stride,
SCM *result),
SCM new_degree, SCM spline)
{
scm_t_array_handle handle;
scm_t_array_handle handle2;
scm_dynwind_begin (0);
const size_t _new_degree = scm_to_size_t (new_degree);
scm_array_get_handle (spline, &handle);
scm_dynwind_array_handle_release (&handle);
assert_c_rank_1_or_2_array (who, spline, &handle);
size_t dim;
ssize_t stride;
scm_array_handle_get_vector_dim_and_stride (who, spline, &handle,
&dim, &stride);
const SCM *_spline = scm_array_handle_elements (&handle);
if (_new_degree < dim - 1)
the_new_degree_is_not_an_elevation (who, new_degree,
scm_from_size_t (dim - 1), spline);
SCM result = scm_make_array (SCM_UNSPECIFIED,
scm_list_1 (scm_oneplus (new_degree)));
scm_array_get_handle (result, &handle2);
scm_dynwind_array_handle_release (&handle2);
SCM *_result = scm_array_handle_writable_elements (&handle2);
elev_scm_spline (_new_degree, dim - 1, stride, _spline, 1, _result);
scm_dynwind_end ();
return result;
}
/*! \brief Print a representation of a gEDA smob.
* \par Function Description
* Outputs a string representing the gEDA \a smob to a Scheme output
* \a port. The format used is "#<geda-TYPE b7ef65d0>", where TYPE is
* a string describing the C structure represented by the gEDA smob.
*
* Used internally to Guile.
*/
static int
smob_print (SCM smob, SCM port, scm_print_state *pstate)
{
gchar *hexstring;
scm_puts ("#<geda-", port);
switch (EDASCM_SMOB_TYPE (smob)) {
case GEDA_SMOB_TOPLEVEL:
scm_puts ("toplevel", port);
break;
case GEDA_SMOB_PAGE:
scm_puts ("page", port);
break;
case GEDA_SMOB_OBJECT:
scm_puts ("object", port);
break;
case GEDA_SMOB_CONFIG:
scm_puts ("config", port);
break;
case GEDA_SMOB_CLOSURE:
scm_puts ("closure", port);
break;
default:
g_critical ("%s: received bad smob flags.", __FUNCTION__);
scm_puts ("unknown", port);
}
if (SCM_SMOB_DATA (smob) != 0) {
scm_dynwind_begin (0);
hexstring = g_strdup_printf (" %p", (void *) SCM_SMOB_DATA (smob));
scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
scm_puts (hexstring, port);
scm_dynwind_end ();
} else {
scm_puts (" (null)", port);
}
scm_puts (">", port);
/* Non-zero means success */
return 1;
}
static SCM scm_launch_program(SCM prog)
{
scm_dynwind_begin(0);
char *c_path = scm_to_locale_string(scm_car(prog));
scm_dynwind_free(c_path);
fprintf(stderr, "launching program %s\n", c_path);
pid_t pid = fork();
if (pid == 0) {
if (scm_is_false(scm_execlp(scm_car(prog), prog))) {
perror("execl failed");
exit(2);
}
}
else {
fprintf(stderr, "launched %s as pid %d\n", c_path, pid);
}
scm_dynwind_end();
return SCM_UNSPECIFIED;
}
/*! \brief Guile callback for adding library commands.
* \par Function Description
* Callback function for the "component-library-command" Guile
* function, which can be used in the rc files to add a command to
* the component library.
*
* \param [in] listcmd command to get a list of symbols
* \param [in] getcmd command to get a symbol from the library
* \param [in] name Optional descriptive name for component source.
* \return SCM_BOOL_T on success, SCM_BOOL_F otherwise.
*/
SCM g_rc_component_library_command (SCM listcmd, SCM getcmd,
SCM name)
{
const CLibSource *src;
gchar *lcmdstr, *gcmdstr;
char *tmp_str, *namestr;
SCM_ASSERT (scm_is_string (listcmd), listcmd, SCM_ARG1,
"component-library-command");
SCM_ASSERT (scm_is_string (getcmd), getcmd, SCM_ARG2,
"component-library-command");
SCM_ASSERT (scm_is_string (name), name, SCM_ARG3,
"component-library-command");
scm_dynwind_begin(0);
/* take care of any shell variables */
/*! \bug this may be a security risk! */
tmp_str = scm_to_utf8_string (listcmd);
lcmdstr = s_expand_env_variables (tmp_str);
scm_dynwind_unwind_handler (g_free, lcmdstr, SCM_F_WIND_EXPLICITLY);
free (tmp_str); /* this should stay as free (allocated from guile) */
/* take care of any shell variables */
/*! \bug this may be a security risk! */
tmp_str = scm_to_utf8_string (getcmd);
gcmdstr = s_expand_env_variables (tmp_str);
scm_dynwind_unwind_handler (g_free, gcmdstr, SCM_F_WIND_EXPLICITLY);
free (tmp_str); /* this should stay as free (allocated from guile) */
namestr = scm_to_utf8_string (name);
src = s_clib_add_command (lcmdstr, gcmdstr, namestr);
free (namestr); /* this should stay as free (allocated from guile) */
scm_dynwind_end();
if (src != NULL) return SCM_BOOL_T;
return SCM_BOOL_F;
}
SCM
scm_internal_dynamic_wind (scm_t_guard before,
scm_t_inner inner,
scm_t_guard after,
void *inner_data,
void *guard_data)
{
SCM ans;
scm_c_issue_deprecation_warning
("`scm_internal_dynamic_wind' is deprecated. "
"Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
ans = inner (inner_data);
scm_dynwind_end ();
return ans;
}
SCM scm_mmr_check_file_perms(SCM target ,SCM perms)
#define FUNC_NAME "check-file-perms"
{
int p = 0;
char *filename = NULL;
SCM ret = SCM_BOOL_F;
struct stat sb;
int mode = 0;
int pa = 0 ,pu = 0 ,pr = 0;
SCM_VALIDATE_STRING(1 ,target);
SCM_VALIDATE_NUMBER(2 ,perms);
scm_dynwind_begin(0);
errno = 0;
p = scm_to_int(perms);
filename = scm_to_locale_string(target);
scm_dynwind_free(filename);
if(stat(filename ,&sb))
{
goto end;
}
mode = sb.st_mode;
pa = PERMS_A & p;
pu = PERMS_U & p;
pr = PERMS_R & p;
if((pa == (mode & pa)) ||
(pu == (mode & pu)) ||
(pr == (mode & pr)))
{
ret = SCM_BOOL_T;
}
end:
scm_dynwind_end();
return ret;
}
static SCM g_get_duplicogram(void)
{
SCM lst = SCM_EOL;
uint64_t const nb_pkts = nb_nodups + nb_dups;
scm_dynwind_begin(0);
mutex_lock(&dup_lock);
scm_dynwind_unwind_handler(pthread_mutex_unlock_, &dup_lock.mutex, SCM_F_WIND_EXPLICITLY);
unsigned dt = bucket_width/2;
for (unsigned x = 0; x < nb_buckets; x++, dt += bucket_width) {
lst = scm_cons(
scm_cons(scm_from_uint(dt),
scm_from_double(nb_pkts > 0 ? (double)dups[x] / nb_pkts : 0.)),
lst);
}
dup_reset_locked();
scm_dynwind_end();
return lst;
}
/*! \brief Verify the version of the RC file under evaluation.
* \par Function Description
*
* Implements the Scheme function "gschem-version". Tests the version
* string in the argument against the version of the application
* itself.
*
* \param [in] scm_version Scheme object containing RC file version string
*
* \returns #t if the version of the RC file matches the application,
* else #f.
*/
SCM g_rc_gschem_version(SCM scm_version)
{
SCM ret;
char *version;
SCM rc_filename;
char *sourcefile;
SCM_ASSERT (scm_is_string (scm_version), scm_version,
SCM_ARG1, "gschem-version");
scm_dynwind_begin (0);
version = scm_to_utf8_string (scm_version);
scm_dynwind_free (version);
if (g_utf8_collate (g_utf8_casefold (version,-1),
g_utf8_casefold (PACKAGE_DATE_VERSION,-1)) != 0) {
sourcefile = NULL;
rc_filename = g_rc_rc_filename ();
if (rc_filename == SCM_BOOL_F) {
rc_filename = scm_from_utf8_string ("unknown");
}
sourcefile = scm_to_utf8_string (rc_filename);
scm_dynwind_free (sourcefile);
fprintf(stderr,
_("You are running gEDA/gaf version [%s%s.%s],\n"),
PREPEND_VERSION_STRING, PACKAGE_DOTTED_VERSION,
PACKAGE_DATE_VERSION);
fprintf(stderr,
_("but you have a version [%s] gschemrc file:\n[%s]\n"),
version, sourcefile);
fprintf(stderr,
_("Please be sure that you have the latest rc file.\n"));
ret = SCM_BOOL_F;
} else {
ret = SCM_BOOL_T;
}
scm_dynwind_end();
return ret;
}
/*! \brief Runs a object hook for a list of objects.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with \a obj_lst as the argument list.
*
* \see g_run_hook_object()
*
* \param name name of hook to run.
* \param obj_lst list of #OBJECT smobs as hook argument.
*/
void
g_run_hook_object_list (GschemToplevel *w_current, const char *name,
GList *obj_lst)
{
SCM lst = SCM_EOL;
GList *iter;
scm_dynwind_begin (0);
g_dynwind_window (w_current);
for (iter = obj_lst; iter != NULL; iter = g_list_next (iter)) {
lst = scm_cons (edascm_from_object ((OBJECT *) iter->data), lst);
}
SCM expr = scm_list_3 (run_hook_sym,
g_get_hook_by_name (name),
scm_cons (list_sym,
scm_reverse_x (lst, SCM_EOL)));
g_scm_eval_protected (expr, scm_interaction_environment ());
scm_dynwind_end ();
scm_remember_upto_here_1 (expr);
}
/************************************************************
* Style Sheet Selection Dialog *
************************************************************/
static void
gnc_style_sheet_select_dialog_add_one(StyleSheetDialog * ss,
SCM sheet_info,
gboolean select)
{
SCM get_name, scm_name;
const gchar *c_name;
char * str;
GtkTreeSelection *selection;
GtkTreeIter iter;
get_name = scm_c_eval_string("gnc:html-style-sheet-name");
scm_name = scm_call_1(get_name, sheet_info);
scm_dynwind_begin (0);
str = scm_to_locale_string (scm_name);
c_name = g_strdup (str);
scm_dynwind_free (str);
scm_dynwind_end ();
if (!c_name)
return;
/* add the column name */
scm_gc_protect_object(sheet_info);
gtk_list_store_append (ss->list_store, &iter);
gtk_list_store_set (ss->list_store, &iter,
/* Translate the displayed name */
COLUMN_NAME, _(c_name),
COLUMN_STYLESHEET, sheet_info,
-1);
/* The translation of the name fortunately doesn't affect the
* lookup because that is done through the sheet_info argument. */
if (select)
{
selection = gtk_tree_view_get_selection (ss->list_view);
gtk_tree_selection_select_iter (selection, &iter);
}
}
static int
my_main (int argc, char **argv)
{
setlocale (LC_ALL, "");
scm_dynwind_begin (0);
CBLAS_SIDE_t Side = side_func (argv[1]);
CBLAS_UPLO_t Uplo = uplo_func (argv[2]);
CBLAS_TRANSPOSE_t TransA = trans_func (argv[3]);
CBLAS_DIAG_t Diag = diag_func (argv[4]);
int m = atoi (argv[5]);
int n = atoi (argv[6]);
mpq_t alpha;
mpq_init (alpha);
scm_dynwind_mpq_clear (alpha);
mpq_set_str (alpha, argv[7], 0);
mpq_canonicalize (alpha);
int k = (Side == CblasLeft) ? m : n;
mpq_t A[k][k];
mpq_matrix_init (k, k, A);
scm_dynwind_mpq_matrix_clear (k, k, A);
mpq_t B[m][n];
mpq_matrix_init (m, n, B);
scm_dynwind_mpq_matrix_clear (m, n, B);
double A1[k][k];
double B1[m][n];
gsl_matrix_view mA1 = gsl_matrix_view_array (&A1[0][0], k, k);
gsl_matrix_view mB1 = gsl_matrix_view_array (&B1[0][0], m, n);
unsigned int i_argv = 8;
for (unsigned int i = 0; i < k; i++)
for (unsigned int j = 0; j < k; j++)
{
mpq_set_str (A[i][j], argv[i_argv], 0);
mpq_canonicalize (A[i][j]);
A1[i][j] = mpq_get_d (A[i][j]);
i_argv++;
}
for (unsigned int i = 0; i < m; i++)
for (unsigned int j = 0; j < n; j++)
{
mpq_set_str (B[i][j], argv[i_argv], 0);
mpq_canonicalize (B[i][j]);
B1[i][j] = mpq_get_d (B[i][j]);
i_argv++;
}
mpq_matrix_trmm (Side, Uplo, TransA, Diag, m, n, alpha, A, B);
gsl_blas_dtrmm (Side, Uplo, TransA, Diag, mpq_get_d (alpha), &mA1.matrix,
&mB1.matrix);
int exit_status = 0;
// Check that we get the same results as gsl_blas_dtrmm.
for (unsigned int i = 0; i < m; i++)
for (unsigned int j = 0; j < n; j++)
{
gmp_printf ("B[%u][%u] = %lf\t%Qd\n", i, j, B1[i][j], B[i][j]);
if (10000 * DBL_EPSILON < fabs (mpq_get_d (B[i][j]) - B1[i][j]))
exit_status = 1;
}
scm_dynwind_end ();
return exit_status;
}
static void
cmd_export_impl (void *data, int argc, char **argv)
{
int i;
GError *err = NULL;
gchar *tmp;
const gchar *out_suffix;
struct ExportFormat *exporter = NULL;
GArray *render_color_map = NULL;
gchar *original_cwd = g_get_current_dir ();
gtk_init_check (&argc, &argv);
scm_init_guile ();
libgeda_init ();
scm_dynwind_begin (0);
toplevel = s_toplevel_new ();
edascm_dynwind_toplevel (toplevel);
/* Now load rc files, if necessary */
if (getenv ("GAF_INHIBIT_RCFILES") == NULL) {
g_rc_parse (toplevel, "gaf export", NULL, NULL);
}
i_vars_libgeda_set (toplevel); /* Ugh */
/* Parse configuration files */
export_config ();
/* Parse command-line arguments */
export_command_line (argc, argv);
/* If no format was specified, try and guess from output
* filename. */
if (settings.format == NULL) {
out_suffix = strrchr (settings.outfile, '.');
if (out_suffix != NULL) {
out_suffix++; /* Skip '.' */
} else {
fprintf (stderr,
_("ERROR: Cannot infer output format from filename '%s'.\n"),
settings.outfile);
exit (1);
}
}
/* Try and find an exporter function */
tmp = g_utf8_strdown ((settings.format == NULL) ? out_suffix : settings.format, -1);
for (i = 0; formats[i].name != NULL; i++) {
if (strcmp (tmp, formats[i].alias) == 0) {
exporter = &formats[i];
break;
}
}
if (exporter == NULL) {
if (settings.format == NULL) {
fprintf (stderr,
_("ERROR: Cannot find supported format for filename '%s'.\n"),
settings.outfile);
exit (1);
} else {
fprintf (stderr,
_("ERROR: Unsupported output format '%s'.\n"),
settings.format);
fprintf (stderr, see_help_msg);
exit (1);
}
}
g_free (tmp);
/* If more than one schematic/symbol file was specified, check that
* exporter supports multipage output. */
if ((settings.infilec > 1) && !(exporter->flags & OUTPUT_MULTIPAGE)) {
fprintf (stderr,
_("ERROR: Selected output format does not support multipage output\n"));
exit (1);
}
/* Load schematic files */
while (optind < argc) {
PAGE *page;
tmp = argv[optind++];
page = s_page_new (toplevel, tmp);
if (!f_open (toplevel, page, tmp, &err)) {
fprintf (stderr,
_("ERROR: Failed to load '%s': %s\n"), tmp,
err->message);
exit (1);
}
if (g_chdir (original_cwd) != 0) {
fprintf (stderr,
_("ERROR: Failed to change directory to '%s': %s\n"),
original_cwd, g_strerror (errno));
exit (1);
}
}
/* Create renderer */
renderer = eda_renderer_new (NULL, NULL);
if (settings.font != NULL) {
g_object_set (renderer, "font-name", settings.font, NULL);
}
/* Make sure libgeda knows how to calculate the bounds of text
* taking into account font etc. */
o_text_set_rendered_bounds_func (toplevel,
export_text_rendered_bounds,
renderer);
/* Create color map */
render_color_map =
g_array_sized_new (FALSE, FALSE, sizeof(GedaColor), MAX_COLORS);
render_color_map =
g_array_append_vals (render_color_map, print_colors, MAX_COLORS);
if (!settings.color) {
/* Create a black and white color map. All non-background colors
* are black. */
GedaColor white = {~0, ~0, ~0, ~0, TRUE};
GedaColor black = {0, 0, 0, ~0, TRUE};
for (i = 0; i < MAX_COLORS; i++) {
GedaColor *c = &g_array_index (render_color_map, GedaColor, i);
if (!c->enabled) continue;
if (c->a == 0) {
c->enabled = FALSE;
continue;
}
if (i == OUTPUT_BACKGROUND_COLOR) {
*c = white;
} else {
*c = black;
}
}
}
eda_renderer_set_color_map (renderer, render_color_map);
/* Render */
exporter->func ();
scm_dynwind_end ();
exit (0);
}