static SCM
scm_gnumeric_funcall (SCM funcname, SCM arglist)
{
int i, num_args;
GnmValue **argvals;
GnmValue *retval;
SCM retsmob;
GnmCellRef cell_ref = { 0, 0, 0, 0 };
SCM_ASSERT (SCM_NIMP (funcname) && SCM_STRINGP (funcname), funcname, SCM_ARG1, "gnumeric-funcall");
SCM_ASSERT (SCM_NFALSEP (scm_list_p (arglist)), arglist, SCM_ARG2, "gnumeric-funcall");
num_args = scm_ilength (arglist);
argvals = g_new (GnmValue *, num_args);
for (i = 0; i < num_args; ++i) {
argvals[i] = scm_to_value (SCM_CAR (arglist));
arglist = SCM_CDR (arglist);
}
retval = function_call_with_values (eval_pos, SCM_CHARS (funcname),
num_args,argvals);
retsmob = value_to_scm (retval, cell_ref);
value_release (retval);
return retsmob;
}
static SCM
ppscm_search_pp_list (SCM list, SCM value)
{
SCM orig_list = list;
if (scm_is_null (list))
return SCM_BOOL_F;
if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), list);
}
for ( ; scm_is_pair (list); list = scm_cdr (list))
{
SCM matcher = scm_car (list);
SCM worker;
pretty_printer_smob *pp_smob;
if (!ppscm_is_pretty_printer (matcher))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list contains non-pretty-printer object"),
matcher);
}
pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
/* Skip if disabled. */
if (gdbscm_is_false (pp_smob->enabled))
continue;
if (!gdbscm_is_procedure (pp_smob->lookup))
{
return ppscm_make_pp_type_error_exception
(_("invalid lookup object in pretty-printer matcher"),
pp_smob->lookup);
}
worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
value, gdbscm_memory_error_p);
if (!gdbscm_is_false (worker))
{
if (gdbscm_is_exception (worker))
return worker;
if (ppscm_is_pretty_printer_worker (worker))
return worker;
return ppscm_make_pp_type_error_exception
(_("invalid result from pretty-printer lookup"), worker);
}
}
if (!scm_is_null (list))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), orig_list);
}
return SCM_BOOL_F;
}
SCM tf_add_gradient_(SCM scm_graph, SCM scm_expression, SCM scm_variables)
{
SCM retval;
if (scm_is_true(scm_list_p(scm_variables))) {
struct tf_graph_t *graph = get_tf_graph(scm_graph);
struct tf_output_t *expression = get_tf_output(scm_expression);
int nvariables = scm_ilength(scm_variables);
TF_Output *variables = scm_gc_calloc(sizeof(TF_Output) * nvariables, "tf-add-gradient_");
for (int i=0; i<nvariables; i++) {
variables[i] = get_tf_output(scm_car(scm_variables))->output;
scm_variables = scm_cdr(scm_variables);
};
TF_Output *output = scm_gc_calloc(sizeof(TF_Output) * nvariables, "tf-add-gradient_");
TF_AddGradients(graph->graph, &expression->output, 1, variables, nvariables, NULL, status(), output);
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("tf-add-gradient_", TF_Message(_status), SCM_EOL);
retval = SCM_EOL;
for (int i=nvariables-1; i>=0; i--) {
SCM element;
struct tf_output_t *result = scm_gc_calloc(sizeof(struct tf_output_t), "tf-add-gradient_");
SCM_NEWSMOB(element, tf_output_tag, result);
result->output = output[i];
retval = scm_cons(element, retval);
};
} else
retval = scm_car(tf_add_gradient_(scm_graph, scm_expression, scm_list_1(scm_variables)));
return retval;
}
/*! \brief read the configuration string list for the component dialog
* \par Function Description
* This function reads the string list from the component-dialog-attributes
* configuration parameter and converts the list into a GList.
* The GList is stored in the global default_component_select_attrlist variable.
*/
SCM g_rc_component_dialog_attributes(SCM stringlist)
{
int length, i;
GList *list=NULL;
gchar *attr;
SCM_ASSERT(scm_list_p(stringlist), stringlist, SCM_ARG1, "scm_is_list failed");
length = scm_ilength(stringlist);
/* If the command is called multiple times, remove the old list before
recreating it */
g_list_foreach(default_component_select_attrlist, (GFunc)g_free, NULL);
g_list_free(default_component_select_attrlist);
/* convert the scm list into a GList */
for (i=0; i < length; i++) {
SCM_ASSERT(scm_is_string(scm_list_ref(stringlist, scm_from_int(i))),
scm_list_ref(stringlist, scm_from_int(i)), SCM_ARG1,
"list element is not a string");
attr = g_strdup(SCM_STRING_CHARS(scm_list_ref(stringlist, scm_from_int(i))));
list = g_list_prepend(list, attr);
}
default_component_select_attrlist = g_list_reverse(list);
return SCM_BOOL_T;
}
SCM tf_run(SCM scm_session, SCM scm_input, SCM scm_output)
{
SCM retval;
if (scm_is_true(scm_list_p(scm_output))) {
struct tf_session_t *session = get_tf_session(scm_session);
int ninputs = scm_ilength(scm_input);
TF_Output *inputs = scm_gc_malloc(sizeof(TF_Output) * ninputs, "tf-run");
TF_Tensor **input_values = scm_gc_malloc(sizeof(TF_Tensor *) * ninputs, "tf-run");
for (int i=0; i<ninputs; i++) {
memcpy(&inputs[i], &get_tf_output(scm_caar(scm_input))->output, sizeof(TF_Output));
input_values[i] = get_tf_tensor(scm_cdar(scm_input))->tensor;
scm_input = scm_cdr(scm_input);
};
int noutputs = scm_ilength(scm_output);
TF_Output *output = scm_gc_malloc(sizeof(TF_Output) * noutputs, "tf-run");
TF_Tensor **output_values = scm_gc_malloc(sizeof(TF_Tensor *) * noutputs, "tf-run");
for (int i=0; i<noutputs; i++) {
output[i] = get_tf_output(scm_car(scm_output))->output;
scm_output = scm_cdr(scm_output);
};
TF_SessionRun(session->session, NULL, inputs, input_values, ninputs, output, output_values, noutputs, NULL, 0, NULL, status());
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("tf-run", TF_Message(_status), SCM_EOL);
retval = SCM_EOL;
for (int i=noutputs-1; i>=0; i--) {
SCM element;
struct tf_tensor_t *result = (struct tf_tensor_t *)scm_gc_calloc(sizeof(struct tf_tensor_t), "make-tensor");
SCM_NEWSMOB(element, tf_tensor_tag, result);
result->tensor = output_values[i];
retval = scm_cons(element, retval);
};
} else
retval = scm_car(tf_run(scm_session, scm_input, scm_list_1(scm_output)));
return retval;
}
static SCM
gdbscm_set_pretty_printers_x (SCM printers)
{
SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
SCM_ARG1, FUNC_NAME, _("list"));
pretty_printer_list = printers;
return SCM_UNSPECIFIED;
}
SCM g_rc_print_color_map (SCM scm_map)
{
if (scm_map == SCM_UNDEFINED) {
return s_color_map_to_scm (print_colors);
}
SCM_ASSERT (scm_is_true (scm_list_p (scm_map)),
scm_map, SCM_ARG1, "print-color-map");
s_color_map_from_scm (print_colors, scm_map, "print-color-map");
return SCM_BOOL_T;
}
/*! \brief Re-poll a scheme procedure for symbols.
* \par Function Description
* Calls a Scheme procedure to obtain a list of available symbols,
* and updates the source with the new list
*
* Private function used only in s_clib.c.
*/
static void refresh_scm (CLibSource *source)
{
SCM symlist;
SCM symname;
CLibSymbol *symbol;
char *tmp;
g_return_if_fail (source != NULL);
g_return_if_fail (source->type == CLIB_SCM);
/* Clear the current symbol list */
g_list_foreach (source->symbols, (GFunc) free_symbol, NULL);
g_list_free (source->symbols);
source->symbols = NULL;
symlist = scm_call_0 (source->list_fn);
if (scm_is_false (scm_list_p (symlist))) {
s_log_message (_("Failed to scan library [%1$s]: Scheme function returned non-list."),
source->name);
return;
}
while (!scm_is_null (symlist)) {
symname = SCM_CAR (symlist);
if (!scm_is_string (symname)) {
s_log_message (_("Non-string symbol name while scanning library [%1$s]"),
source->name);
} else {
symbol = g_new0 (CLibSymbol, 1);
symbol->source = source;
/* Need to make sure that the correct free() function is called
* on strings allocated by Guile. */
tmp = scm_to_utf8_string (symname);
symbol->name = g_strdup(tmp);
free (tmp);
/* Prepend because it's faster and it doesn't matter what order we
* add them. */
source->symbols = g_list_prepend (source->symbols, symbol);
}
symlist = SCM_CDR (symlist);
}
/* Now sort the list of symbols by name. */
source->symbols = g_list_sort (source->symbols,
(GCompareFunc) compare_symbol_name);
s_clib_flush_search_cache();
s_clib_flush_symbol_cache();
}
SCM g_rc_display_outline_color_map (SCM scm_map)
{
if (scm_map == SCM_UNDEFINED) {
return s_color_map_to_scm (display_outline_colors);
}
SCM_ASSERT (scm_is_true (scm_list_p (scm_map)),
scm_map, SCM_ARG1, "display-outline-color-map");
s_color_map_from_scm (display_outline_colors, scm_map, "display-outline-color-map");
return SCM_BOOL_T;
}
/*! \todo Finish function description!!!
* \brief
* \par Function Description
*
* \param [in] attrlist
* \return SCM_BOOL_T always.
*/
SCM g_rc_always_promote_attributes(SCM attrlist)
{
GList *list=NULL;
int length, i;
gchar *attr;
gchar **attr2;
g_list_foreach(default_always_promote_attributes, (GFunc)g_free, NULL);
g_list_free(default_always_promote_attributes);
if (scm_is_string (attrlist)) {
char *temp;
s_log_message(_("WARNING: using a string for 'always-promote-attributes'"
" is deprecated. Use a list of strings instead\n"));
/* convert the space separated strings into a GList */
temp = scm_to_utf8_string (attrlist);
attr2 = g_strsplit(temp," ", 0);
free (temp);
for (i=0; attr2[i] != NULL; i++) {
if (strlen(attr2[i]) > 0) {
list = g_list_prepend(list, g_strdup(attr2[i]));
}
}
g_strfreev(attr2);
} else {
SCM_ASSERT(scm_list_p(attrlist), attrlist, SCM_ARG1, "always-promote-attributes");
length = scm_ilength(attrlist);
/* convert the scm list into a GList */
for (i=0; i < length; i++) {
char *temp;
SCM_ASSERT(scm_is_string(scm_list_ref(attrlist, scm_from_int(i))),
scm_list_ref(attrlist, scm_from_int(i)), SCM_ARG1,
"always-promote-attribute: list element is not a string");
temp = scm_to_utf8_string (scm_list_ref (attrlist, scm_from_int (i)));
attr = g_strdup(temp);
free (temp);
list = g_list_prepend(list, attr);
}
}
default_always_promote_attributes = g_list_reverse(list);
return SCM_BOOL_T;
}
/* get confinement from SCM
* in SCM, confinement is given by one of these:
* for spherical confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "sphere"
* 10.0 ;; radius of the cavity at (0, 0, 0)
* ))
* for spherical confinement with a hole,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "sphere+hole"
* 10.0 ;; radius of the cavity at (0, 0, 0)
* 1.0 ;; radius of the hole at (0, 0, 1) direction
* ))
* for cylindrical confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "cylinder" ;; the cylinder center goes through (0, 0, 0) and (x, y, z).
* 10.0 ;; radius of the cylinder
* 1.0 0.0 0.0 ;; direction vector (x, y, z) of the cylinder
* ))
* for dumbbell confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "dumbbell" ;; the origin is at the center of the cylinder
* 10.0 ;; left cavity radius centered at (center1, 0, 0)
* 10.0 ;; right cavity radius centered at (center2, 0, 0)
* 2.0 ;; length of the cylinder
* 1.0 ;; cylinder radius
* ))
* for 2D hexagonal confinement with cylinder pipe,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "hex2d"
* 10.0 ;; cavity radius
* 1.0 ;; cylinder radius
* 12.0 ;; lattice spacing
* ))
* for porous media (outside of the 3D hexagonal particle array)
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "porous"
* 10.0 ;; particle radius
* 20.0 ;; lattice spacing in x (2R for touching case)
* ))
* INPUT
* var : name of the variable.
* in the above example, set "confinement".
* OUTPUT
* returned value : struct confinement
* if NULL is returned, it failed (not defined)
*/
struct confinement *
CF_guile_get (const char *var)
{
if (guile_check_symbol (var) == 0)
{
fprintf (stderr, "CF_guile_get: %s is not defined\n", var);
return (NULL);
}
SCM scm_symbol
= scm_c_lookup (var);
SCM scm_confinement
= scm_variable_ref (scm_symbol);
if (!SCM_NFALSEP (scm_list_p (scm_confinement)))
{
fprintf (stderr, "CF_guile_get: %s is not a list\n", var);
return (NULL);
}
struct confinement *cf = NULL;
unsigned long len
= scm_num2ulong (scm_length (scm_confinement),
0, "CF_guile_get");
if (len == 0)
{
// no confinement
return (cf);
}
else if (len < 4)
{
fprintf (stderr, "CF_guile_get: %s is too short\n", var);
return (NULL);
}
double epsilon
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (0)),
"CF_guile_get");
double r0
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (1)),
"CF_guile_get");
// get the string
char *str_cf = NULL;
SCM scm_conf = scm_list_ref (scm_confinement, scm_int2num (2));
#ifdef GUILE16
size_t str_len;
if (gh_string_p (scm_conf))
{
str_cf = gh_scm2newstr (scm_conf, &str_len);
}
#else // !GUILE16
if (scm_is_string (scm_conf))
{
str_cf = scm_to_locale_string (scm_conf);
}
#endif // GUILE16
if (strcmp (str_cf, "sphere") == 0)
{
if (len != 4)
{
fprintf (stderr, "CF_guile_get:"
" for sphere, number of parameter must be 1\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
cf = CF_init (0, // sphere
R,
0.0, // r
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "sphere+hole") == 0)
{
if (len != 5)
{
fprintf (stderr, "CF_guile_get:"
" for sphere+hole, number of parameter must be 2\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
cf = CF_init (1, // sphere+hole
R,
r,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "cylinder") == 0)
{
if (len != 7)
{
fprintf (stderr, "CF_guile_get:"
" for cylinder, number of parameter must be 4\n");
}
else
{
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double x
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double y
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
double z
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (6)),
"CF_guile_get");
cf = CF_init (2, // cylinder
0.0, // R,
r,
x, y, z,
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "dumbbell") == 0)
{
if (len != 7)
{
fprintf (stderr, "CF_guile_get:"
" for dumbbell, number of parameter must be 4\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double R2
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (6)),
"CF_guile_get");
cf = CF_init (3, // dumbbell
R,
r,
0.0, 0.0, 0.0, // x, y, z
R2,
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "hex2d") == 0)
{
if (len != 6)
{
fprintf (stderr, "CF_guile_get:"
" for hex2d, number of parameter must be 3\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
cf = CF_init (4, // hex2d
R,
r,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "porous") == 0)
{
if (len != 5)
{
fprintf (stderr, "CF_guile_get:"
" for hex2d, number of parameter must be 2\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
cf = CF_init (5, // porous
R,
0.0,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else
{
fprintf (stderr, "CF_guile_get: invalid confinement %s\n",
str_cf);
}
free (str_cf);
return (cf); // success
}
/*! \brief Get the object bounds of the given object, excluding the object
* types or the attributes given as parameters.
* \par Function Description
* Get the object bounds without considering the attributes in
* scm_exclude_attribs, neither the object types included in
* scm_exclude_object_type
* \param [in] object_smob The object we want to know the bounds of.
* \param [in] exclude_attrib_list A list with the attribute names we don't
* want to include when calculing the bounds.
* \param [in] exclude_obj_type_list A list with the object types we don't
* want to include when calculing the bounds.
* The object types are those used in (OBJECT *)->type converted into strings.
* \return a list of the bounds of the <B>object smob</B>.
* The list has the format: ( (left right) (top bottom) )
* WARNING: top and bottom are mis-named in world-coords,
* top is the smallest "y" value, and bottom is the largest.
* Be careful! This doesn't correspond to what you'd expect,
* nor to the coordinate system who's origin is the bottom, left of the page.
*/
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type)
{
TOPLEVEL *toplevel=NULL;
OBJECT *object=NULL;
int left=0, right=0, bottom=0, top=0;
SCM returned = SCM_EOL;
SCM vertical = SCM_EOL;
SCM horizontal = SCM_EOL;
GList *exclude_attrib_list = NULL, *exclude_obj_type_list = NULL;
gboolean exclude_all_attribs = FALSE;
int i;
SCM_ASSERT (scm_list_p(scm_exclude_attribs), scm_exclude_attribs,
SCM_ARG2, "get-object-bounds");
SCM_ASSERT (scm_list_p(scm_exclude_object_type), scm_exclude_object_type,
SCM_ARG3, "get-object-bounds");
/* Build the exclude attrib list */
for (i=0; i <= scm_to_int(scm_length(scm_exclude_attribs))-1; i++) {
SCM_ASSERT (scm_is_string(scm_list_ref(scm_exclude_attribs, scm_from_int(i))),
scm_exclude_attribs,
SCM_ARG2, "get-object-bounds");
exclude_attrib_list = g_list_append(exclude_attrib_list,
SCM_STRING_CHARS(scm_list_ref(scm_exclude_attribs,
scm_from_int(i))));
}
/* Build the exclude object type list */
for (i=0; i <= scm_to_int(scm_length(scm_exclude_object_type))-1; i++) {
SCM_ASSERT (scm_is_string(scm_list_ref(scm_exclude_object_type, scm_from_int(i))),
scm_exclude_object_type,
SCM_ARG3, "get-object-bounds");
exclude_obj_type_list = g_list_append(exclude_obj_type_list,
SCM_STRING_CHARS(scm_list_ref(scm_exclude_object_type,
scm_from_int(i))));
}
/* Get toplevel and o_current. */
g_get_data_from_object_smob (object_smob, &toplevel, &object);
SCM_ASSERT (toplevel && object,
object_smob, SCM_ARG1, "get-object-bounds");
if (g_list_find_custom(exclude_attrib_list, "all", (GCompareFunc) &strcmp))
exclude_all_attribs = TRUE;
custom_world_get_single_object_bounds (toplevel, object,
&left, &top,
&right, &bottom,
exclude_attrib_list,
exclude_obj_type_list);
/* Free the exclude attrib_list. Don't free the nodes!! */
g_list_free(exclude_attrib_list);
/* Free the exclude attrib_list. Don't free the nodes!! */
g_list_free(exclude_obj_type_list);
horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
returned = scm_cons (horizontal, vertical);
return (returned);
}
/*
* Adds an attribute <B>scm_attrib_name</B> with value <B>scm_attrib_value</B> to the given <B>object</B>.
The attribute has the visibility <B>scm_vis</B> and show <B>scm_show</B> flags.
The possible values are:
- <B>scm_vis</B>: scheme boolean. Visible (TRUE) or hidden (FALSE).
- <B>scm_show</B>: a list containing what to show: "name", "value", or both.
The return value is always TRUE.
*/
SCM g_add_attrib(SCM object, SCM scm_attrib_name,
SCM scm_attrib_value, SCM scm_vis, SCM scm_show)
{
GSCHEM_TOPLEVEL *w_current=global_window_current;
TOPLEVEL *toplevel = w_current->toplevel;
OBJECT *o_current=NULL;
gboolean vis;
int show=0;
gchar *attrib_name=NULL;
gchar *attrib_value=NULL;
gchar *value=NULL;
int i;
gchar *newtext=NULL;
SCM_ASSERT (scm_is_string(scm_attrib_name), scm_attrib_name,
SCM_ARG2, "add-attribute-to-object");
SCM_ASSERT (scm_is_string(scm_attrib_value), scm_attrib_value,
SCM_ARG3, "add-attribute-to-object");
SCM_ASSERT (scm_boolean_p(scm_vis), scm_vis,
SCM_ARG4, "add-attribute-to-object");
SCM_ASSERT (scm_list_p(scm_show), scm_show,
SCM_ARG5, "add-attribute-to-object");
/* Get toplevel and o_current */
SCM_ASSERT (g_get_data_from_object_smob (object, &toplevel, &o_current),
object, SCM_ARG1, "add-attribute-to-object");
/* Get parameters */
attrib_name = SCM_STRING_CHARS(scm_attrib_name);
attrib_value = SCM_STRING_CHARS(scm_attrib_value);
vis = SCM_NFALSEP(scm_vis);
for (i=0; i<=scm_to_int(scm_length(scm_show))-1; i++) {
/* Check every element in the list. It should be a string! */
SCM_ASSERT(scm_list_ref(scm_show, scm_from_int(i)),
scm_show,
SCM_ARG5, "add-attribute-to-object");
SCM_ASSERT(scm_is_string(scm_list_ref(scm_show, scm_from_int(i))),
scm_show,
SCM_ARG5, "add-attribute-to-object");
value = SCM_STRING_CHARS(scm_list_ref(scm_show, scm_from_int(i)));
SCM_ASSERT(value, scm_show,
SCM_ARG5, "add-attribute-to-object");
/* Only "name" or "value" strings are allowed */
SCM_ASSERT(!((strcasecmp(value, "name") != 0) &&
(strcasecmp(value, "value") != 0) ), scm_show,
SCM_ARG5, "add-attribute-to-object");
/* show = 1 => show value;
show = 2 => show name;
show = 3 => show both */
if (strcasecmp(value, "value") == 0) {
show |= 1;
}
else if (strcasecmp(value, "name") == 0) {
show |= 2;
}
}
/* Show name and value (show = 3) => show=0 for gschem */
if (show == 3) {
show = 0;
}
newtext = g_strdup_printf("%s=%s", attrib_name, attrib_value);
o_attrib_add_attrib (w_current, newtext, vis, show, o_current);
g_free(newtext);
return SCM_BOOL_T;
}
/* \brief Print a list of available backends.
* \par Function Description
* Prints a list of available gnetlist backends by searching for files
* in each of the directories in the current Guile %load-path. A file
* is considered to be a gnetlist backend if its basename begins with
* "gnet-" and ends with ".scm".
*
* \param pr_current Current #TOPLEVEL structure.
*/
void
gnetlist_backends (TOPLEVEL *pr_current)
{
SCM s_load_path;
GList *backend_names = NULL, *iter = NULL;
/* Look up the current Guile %load-path */
s_load_path = scm_variable_ref (scm_c_lookup ("%load-path"));
for ( ; s_load_path != SCM_EOL; s_load_path = scm_cdr (s_load_path)) {
SCM s_dir_name = scm_car (s_load_path);
char *dir_name;
DIR *dptr;
struct dirent *dentry;
/* Get directory name from Scheme */
g_assert (scm_is_true (scm_list_p (s_load_path))); /* Sanity check */
g_assert (scm_is_string (scm_car (s_load_path))); /* Sanity check */
dir_name = scm_to_utf8_string (s_dir_name);
/* Open directory */
dptr = opendir (dir_name);
if (dptr == NULL) {
g_warning ("Can't open directory %s: %s\n",
dir_name, strerror (errno));
continue;
}
free (dir_name);
while (1) {
char *name;
dentry = readdir (dptr);
if (dentry == NULL) break;
/* Check that filename has the right format to be a gnetlist
* backend */
if (!(g_str_has_prefix (dentry->d_name, "gnet-")
&& g_str_has_suffix (dentry->d_name, ".scm")))
continue;
/* Copy filename and remove prefix & suffix. Add to list of
* backend names. */
name = g_strdup (dentry->d_name + 5);
name[strlen(name)-4] = '\0';
backend_names = g_list_prepend (backend_names, name);
}
/* Close directory */
closedir (dptr);
}
/* Sort the list of backends */
backend_names = g_list_sort (backend_names, (GCompareFunc) strcmp);
printf ("List of available backends: \n\n");
for (iter = backend_names; iter != NULL; iter = g_list_next (iter)) {
printf ("%s\n", (char *) iter->data);
}
printf ("\n");
scm_remember_upto_here_1 (s_load_path);
}
int scm_is_list(SCM x) {
return scm_list_p(x) == SCM_BOOL_T;
}
