Beispiel #1
0
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;
}
Beispiel #3
0
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;
}
Beispiel #4
0
/*! \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;
}
Beispiel #5
0
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;
}
Beispiel #7
0
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;
}
Beispiel #8
0
/*! \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();
}
Beispiel #9
0
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;
}
Beispiel #10
0
/*! \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;
}
Beispiel #11
0
/* 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
}
Beispiel #12
0
/*! \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);
}
Beispiel #13
0
/*
 * 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;

}
Beispiel #14
0
/* \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);
}
Beispiel #15
0
int scm_is_list(SCM x) {
	return scm_list_p(x) == SCM_BOOL_T;
}