예제 #1
0
파일: s_clib.c 프로젝트: peter-b/geda-gaf
/*! \brief Add symbol-generating Scheme procedures to the library.
 *  \par Function Description
 *  Adds a source to the library based on Scheme procedures.  See page
 *  \ref libscms for more information. Two procedures are required: \a
 *  listfunc must return a Scheme list of symbol names, and \a getfunc
 *  must return a string containing symbol data when passed a symbol
 *  name.
 *
 *  \param listfunc A Scheme function returning a list of symbols.
 *  \param getfunc  A Scheme function returning symbol data.
 *  \param name     A descriptive name for the component source.
 *
 *  \return         The new CLibSource.
 */
const CLibSource *s_clib_add_scm (SCM listfunc, SCM getfunc, const gchar *name)
{
  CLibSource *source;
  gchar *realname;

  if (name == NULL) {
    s_log_message (_("Cannot add library: name not specified."));
    return NULL;
  }

  realname = uniquify_source_name (name);

  if (scm_is_false (scm_procedure_p (listfunc))
      && scm_is_false (scm_procedure_p (getfunc))) {
    s_log_message (_("Cannot add Scheme-library [%1$s]: callbacks must be closures."),
                   realname);
    return NULL;
  }

  source = g_new0 (CLibSource, 1);
  source->type = CLIB_SCM;
  source->name = realname;
  source->list_fn = scm_gc_protect_object (listfunc);
  source->get_fn = scm_gc_protect_object (getfunc);

  refresh_scm (source);

  clib_sources = g_list_prepend (clib_sources, source);

  return source;
}
예제 #2
0
파일: plugin.c 프로젝트: UIKit0/gnumeric
/*
 * This gets called if scm_apply throws an error.
 *
 * We use gh_scm2newstr to convert from Guile string to Scheme string. The
 * GH interface is deprecated, but doing it in scm takes more code. We'll
 * convert later if we have to.
 */
static SCM
gnm_guile_catcher (void *data, SCM tag, SCM throw_args)
{
	char const *header = _("Guile error");
	SCM smob;
	SCM func;
	SCM res;
	char *guilestr = NULL;
	char *msg;
	GnmValue *v;

	func = scm_c_eval_string ("gnm:error->string");
	if (scm_procedure_p (func)) {
		res = scm_apply (func, tag,
				 scm_cons (throw_args, scm_listofnull));
		if (scm_string_p (res))
			guilestr = gh_scm2newstr (res, NULL);
	}

	if (guilestr != NULL) {
		char *buf = g_strdup_printf ("%s: %s", header, guilestr);
		free (guilestr);
		v = value_new_error (NULL, buf);
		g_free (buf);
	} else {
		v = value_new_error (NULL, header);
	}

	smob = make_new_smob (v);
	value_release (v);
	return smob;
}
예제 #3
0
/*! \brief Exports the keymap in scheme to a GLib GArray.
 *  \par Function Description
 *  This function converts the list of key sequence/action pairs
 *  returned by the scheme function \c dump-current-keymap into an
 *  array of C structures.
 *
 *  The returned value must be freed by caller.
 *
 *  \return A GArray with keymap data.
  */
GArray*
g_keys_dump_keymap (void)
{
  SCM dump_proc = scm_c_lookup ("dump-current-keymap");
  SCM scm_ret;
  GArray *ret = NULL;
  struct keyseq_action_t {
    gchar *keyseq, *action;
  };

  dump_proc = scm_variable_ref (dump_proc);
  g_return_val_if_fail (SCM_NFALSEP (scm_procedure_p (dump_proc)), NULL);

  scm_ret = scm_call_0 (dump_proc);
  g_return_val_if_fail (SCM_CONSP (scm_ret), NULL);

  ret = g_array_sized_new (FALSE,
                           FALSE,
                           sizeof (struct keyseq_action_t),
                           (guint)scm_ilength (scm_ret));
  for (; scm_ret != SCM_EOL; scm_ret = SCM_CDR (scm_ret)) {
    SCM scm_keymap_entry = SCM_CAR (scm_ret);
    struct keyseq_action_t keymap_entry;

    g_return_val_if_fail (SCM_CONSP (scm_keymap_entry) &&
                          scm_is_symbol (SCM_CAR (scm_keymap_entry)) &&
                          scm_is_string (SCM_CDR (scm_keymap_entry)), ret);
    keymap_entry.action = g_strdup (SCM_SYMBOL_CHARS (SCM_CAR (scm_keymap_entry)));
    keymap_entry.keyseq = g_strdup (SCM_STRING_CHARS (SCM_CDR (scm_keymap_entry)));
    ret = g_array_append_val (ret, keymap_entry);
  }

  return ret;
}
예제 #4
0
파일: g_rc.c 프로젝트: igutekunst/geda-gaf
/*! \brief Guile callback for adding library functions.
 *  \par Function Description
 *  Callback function for the "component-library-funcs" Guile
 *  function, which can be used in the rc files to add a set of Guile
 *  procedures for listing and generating symbols.
 *
 *  \param [in] listfunc A Scheme procedure which takes no arguments
 *                       and returns a Scheme list of component names.
 *  \param [in] getfunc A Scheme procedure which takes a component
 *                      name as an argument and returns a symbol
 *                      encoded in a string in gEDA format, or the \b
 *                      \#f if the component name is unknown.
 *  \param [in] name    A descriptive name for this component source.
 *
 *  \returns SCM_BOOL_T on success, SCM_BOOL_F otherwise.
 */
SCM g_rc_component_library_funcs (SCM listfunc, SCM getfunc, SCM name)
{
  char *namestr;
  SCM result = SCM_BOOL_F;

  SCM_ASSERT (scm_is_true (scm_procedure_p (listfunc)), listfunc, SCM_ARG1,
	      "component-library-funcs");
  SCM_ASSERT (scm_is_true (scm_procedure_p (getfunc)), getfunc, SCM_ARG2,
	      "component-library-funcs");
  SCM_ASSERT (scm_is_string (name), name, SCM_ARG3, 
	      "component-library-funcs");

  namestr = scm_to_utf8_string (name);

  if (s_clib_add_scm (listfunc, getfunc, namestr) != NULL) {
    result = SCM_BOOL_T;
  }

  free (namestr);
  return result;
}
예제 #5
0
파일: player.c 프로젝트: davexunit/gshmup
void gshmup_set_player_shooting (GshmupPlayer *player, bool shoot)
{
    player->shooting = shoot;

    if (shoot) {
        if (scm_is_true (scm_procedure_p (player->on_shoot))) {
            gshmup_schedule (player->entity.agenda, 0, player->on_shoot);
        }
    } else {
        gshmup_clear_agenda (player->entity.agenda);
    }
}
예제 #6
0
bool mouseAreaMouseUp(guihckContext* ctx, guihckElementId id, void* data, int button, float x, float y)
{
  (void) data;
  (void) button;
  (void) x;
  (void) y;

  bool handled = false;
  SCM pressed = guihckElementGetProperty(ctx, id, "pressed");
  bool clicked = scm_to_bool(pressed);
  guihckElementProperty(ctx, id, "pressed", SCM_BOOL_F);

  {
    SCM handler = guihckElementGetProperty(ctx, id, "on-mouse-up");
    if(scm_to_bool(scm_procedure_p(handler)))
    {
      guihckStackPushElement(ctx, id);
      SCM expression = scm_list_4(handler, scm_from_int8(button), scm_from_double(x), scm_from_double(y));
      SCM result = guihckContextExecuteExpression(ctx, expression);
      handled = scm_is_eq(result, SCM_BOOL_T);
      guihckStackPopElement(ctx);
    }
  }

  if(clicked && !handled)
  {
    SCM handler = guihckElementGetProperty(ctx, id, "on-click");
    if(scm_to_bool(scm_procedure_p(handler)))
    {
      guihckStackPushElement(ctx, id);
      SCM expression = scm_list_4(handler, scm_from_int8(button), scm_from_double(x), scm_from_double(y));
      SCM result = guihckContextExecuteExpression(ctx, expression);
      handled = scm_is_eq(result, SCM_BOOL_T);
      guihckStackPopElement(ctx);
    }
  }

  return handled;
}
예제 #7
0
파일: loop.c 프로젝트: spk121/burro-engine
static void
loop_set_after_draw_frame_func (SCM after_frame)
{
    SCM var = scm_lookup (after_frame);
    if (!scm_is_true (var) || !scm_is_true (scm_variable_p (var)))
    {
        g_critical ("invalid after frame func");
        return;
    }

    SCM ref = guile_variable_ref_safe (var);
    if (!scm_is_true (ref) || !scm_is_true (scm_procedure_p (ref)))
    {
        g_critical ("invalid after frame func");
        return;
    }

    do_after_draw_frame = ref;
}
예제 #8
0
bool mouseAreaMouseMove(guihckContext* ctx, guihckElementId id, void* data, float sx, float sy, float dx, float dy)
{
  (void) data;
  (void) sx;
  (void) sy;
  (void) dx;
  (void) dy;

  bool handled = false;
  SCM handler = guihckElementGetProperty(ctx, id, "on-mouse-move");
  if(scm_to_bool(scm_procedure_p(handler)))
  {
   guihckStackPushElement(ctx, id);
   SCM expression = scm_list_5(handler, scm_from_double(sx), scm_from_double(sy), scm_from_double(dx), scm_from_double(dy));
   SCM result = guihckContextExecuteExpression(ctx, expression);
   handled = scm_is_eq(result, SCM_BOOL_T);
   guihckStackPopElement(ctx);
  }
  return handled;
}
예제 #9
0
파일: loop.c 프로젝트: spk121/burro-engine
static void
loop_set_game_update_func (SCM idle)
{
    SCM var = scm_lookup (idle);
    if (!scm_is_true (var) || !scm_is_true (scm_variable_p (var)))
    {
        g_critical ("invalid game update func");
        return;
    }
#if 0
    SCM ref = guile_variable_ref_safe (var);
    if (!scm_is_true (ref) || !scm_is_true (scm_procedure_p (ref)))
    {
        g_critical ("invalid game update func");
        return;
    }
#endif
    scm_remember_upto_here_1(var);
    do_idle = scm_variable_ref(scm_lookup(idle));
}
예제 #10
0
파일: plugin.c 프로젝트: UIKit0/gnumeric
/*
 * FIXME: If we clean up at exit, removing the registered functions, we get
 * rid of the 'Leaking string [Guile] with ref_count=1' warnings. The way we
 * do this for other plugins, including Python, we deactivate the
 * plugin. However, it is not possible to finalize Guile.
 */
static SCM
scm_register_function (SCM scm_name, SCM scm_args, SCM scm_help, SCM scm_category, SCM scm_function)
{
	GnmFunc *fndef;
	GnmFuncGroup   *cat;
	GnmFuncDescriptor    desc;
	char     *help;

	SCM_ASSERT (SCM_NIMP (scm_name) && SCM_STRINGP (scm_name), scm_name, SCM_ARG1, "scm_register_function");
	SCM_ASSERT (SCM_NIMP (scm_args) && SCM_STRINGP (scm_args), scm_args, SCM_ARG2, "scm_register_function");
	SCM_ASSERT (SCM_NIMP (scm_help) && SCM_STRINGP (scm_help), scm_help, SCM_ARG3, "scm_register_function");
	SCM_ASSERT (SCM_NIMP (scm_category) && SCM_STRINGP (scm_category),
		    scm_category, SCM_ARG4, "scm_register_function");
	SCM_ASSERT (scm_procedure_p (scm_function), scm_function, SCM_ARG5, "scm_register_function");

	scm_permanent_object (scm_function);

	desc.name	= g_strdup (SCM_CHARS (scm_name));
	desc.arg_spec	= g_strdup (SCM_CHARS (scm_args));
	desc.arg_names	= NULL;
	help            = g_strdup (SCM_CHARS (scm_help));
	desc.help       = &help;
	desc.fn_args    = func_marshal_func;
	desc.fn_nodes   = NULL;
	desc.linker     = NULL;
	desc.unlinker   = NULL;
	desc.flags      = 0;
	desc.ref_notify = NULL;
	desc.impl_status = GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC;
	desc.test_status = GNM_FUNC_TEST_STATUS_UNKNOWN;

	cat = gnm_func_group_fetch (SCM_CHARS (scm_category), NULL);
	fndef = gnm_func_add (cat, &desc, NULL);

	gnm_func_set_user_data (fndef, GINT_TO_POINTER (scm_function));

	return SCM_UNSPECIFIED;
}
예제 #11
0
bool
xscm_is_procedure(SCM x)
{
    return scm_is_true (scm_procedure_p (x));
}
예제 #12
0
  /* This scandir is a shrink version of the glibc version.
   * I believe we don't need versionsort or any other sort in the ragnarok.
   */
SCM scm_mmr_scandir(SCM dir, SCM filter)
#define FUNC_NAME "scandir"
{
    struct dirent_or_dirent64 **rdent;
    int has_filter = 0;
    int n = 0 ,i = 0;
    char *tmp_ptr = NULL;
    SCM flag;
    SCM ret = SCM_EOL;
    SCM *prev;
    SCM str;

    SCM_VALIDATE_STRING(1, dir);

    if(!SCM_UNBNDP(filter))
	{
	    SCM_ASSERT(scm_is_true(scm_procedure_p(filter)),
		       filter ,SCM_ARG2 ,FUNC_NAME);
	    has_filter = 1;
	}

    scm_dynwind_begin(0);
    errno = 0;

    tmp_ptr = scm_to_locale_string(dir);
    scm_dynwind_free(tmp_ptr);

    n = scandir_or_scandir64(tmp_ptr,
			     &rdent, NULL,
			     alphasort_or_alphasort64);

    if(has_filter)
	{
	    for(prev = &ret;i<n;i++)
		{
		    str = rdent[i]?
			scm_from_locale_stringn(rdent[i]->d_name ,NAMLEN(rdent[i]))
			:
			SCM_EOF_VAL;
		    flag = scm_call_1(filter ,str);
		    free(rdent[i]);

		    if(scm_is_true(flag))
			{
			    *prev = scm_cons(str ,SCM_EOL);
			    prev = SCM_CDRLOC(*prev);
			}
		}
	}
    else
	{
	    for(prev = &ret;i<n;i++)
		{
		    str = rdent[i]?
			scm_from_locale_stringn(rdent[i]->d_name ,NAMLEN(rdent[i]))
			:
			SCM_EOF_VAL;
		    *prev = scm_cons(str ,SCM_EOL);
		    prev = SCM_CDRLOC(*prev);
		    free(rdent[i]);
		}
	}

    if(errno != 0)
	SCM_SYSERROR;

    scm_dynwind_end();

    free(rdent);
    
    return ret;
}
예제 #13
0
파일: scm2py.c 프로젝트: rlutz/geda-gaf
PyObject *scm2py(SCM value)
{
	if (value == NULL)
		return NULL;
	if (value == SCM_UNSPECIFIED) {
		Py_INCREF(Py_None);
		return Py_None;
	}
	if (scm_is_exact_integer(value))
		return PyInt_FromLong(scm_to_long(value));
	if (scm_is_real(value))
		return PyFloat_FromDouble(scm_to_double(value));
	if (scm_is_bool(value)) {
		PyObject *result = scm_to_bool(value) ? Py_True : Py_False;
		Py_INCREF(result);
		return result;
	}
	if (value == SCM_EOL)
		return PyTuple_New(0);
	if (scm_is_string(value)) {
		size_t len = 0;
		char *s = scm_to_utf8_stringn(value, &len);
		PyObject *result = PyUnicode_FromStringAndSize(s, len);
		free(s);
		return result;
	}
	if (scm_is_pair(value)) {
		unsigned int len = scm_to_uint(scm_length(value));
		PyObject *result = PyTuple_New(len);
		scm_dynwind_begin(0);
		scm_dynwind_unwind_handler(
			(void (*)(void *))Py_DecRef, result, 0);
		unsigned int i;
		for (i = 0; i < len; i++) {
			PyObject *item = scm2py(scm_car(value));
			if (item == NULL) {
				scm_dynwind_end();
				Py_DECREF(result);
				return NULL;
			}
			PyTuple_SET_ITEM(result, i, item);
			value = scm_cdr(value);
		}
		scm_dynwind_end();
		return result;
	}
	if (scm_to_bool(scm_procedure_p(value))) {
		SCM ptr = scm_assq_ref(gsubr_alist, value);
		if (!scm_is_false(ptr)) {
			PyObject *result = scm_to_pointer(ptr);
			Py_INCREF(result);
			return result;
		}
		Procedure *result =
			(Procedure *)ProcedureType.tp_alloc(&ProcedureType, 0);
		if (result == NULL)
			return NULL;
		result->proc = value;
		return (PyObject *)result;
	}

	char *msg = scm_to_utf8_stringn(
		scm_simple_format(
			SCM_BOOL_F,
			scm_from_utf8_string(
				"Guile expression ~S doesn't have a "
				"corresponding Python value"),
			scm_list_1(value)), NULL);
	PyErr_SetString(PyExc_TypeError, msg);
	free(msg);
	return NULL;
}
예제 #14
0
파일: stacks.c 프로젝트: TaylanUB/guile
static long
narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
              SCM inner_cut, SCM outer_cut)
{
  /* Resolve procedure cuts to address ranges, if possible.  If the
     debug information has been stripped, this might not be
     possible.  */
  if (scm_is_true (scm_program_p (inner_cut)))
    {
      SCM addr_range = scm_program_address_range (inner_cut);
      if (scm_is_pair (addr_range))
        inner_cut = addr_range;
    }
  if (scm_is_true (scm_program_p (outer_cut)))
    {
      SCM addr_range = scm_program_address_range (outer_cut);
      if (scm_is_pair (addr_range))
        outer_cut = addr_range;
    }

  /* Cut inner part. */
  if (scm_is_true (scm_procedure_p (inner_cut)))
    {
      /* Cut until the given procedure is seen. */
      for (; len ;)
        {
          SCM proc = scm_c_frame_closure (kind, frame);
          len--;
          scm_c_frame_previous (kind, frame);
          if (scm_is_eq (proc, inner_cut))
            break;
        }
    }
  else if (scm_is_pair (inner_cut)
           && scm_is_integer (scm_car (inner_cut))
           && scm_is_integer (scm_cdr (inner_cut)))
    {
      /* Cut until an IP within the given range is found.  */
      scm_t_uintptr low_pc, high_pc, pc;

      low_pc = scm_to_uintptr_t (scm_car (inner_cut));
      high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));

      for (; len ;)
        {
          pc = (scm_t_uintptr) frame->ip;
          len--;
          scm_c_frame_previous (kind, frame);
          if (low_pc <= pc && pc < high_pc)
            break;
        }
    }
  else if (scm_is_integer (inner_cut))
    {
      /* Cut specified number of frames. */
      long inner = scm_to_int (inner_cut);
      
      for (; inner && len; --inner)
        {
          len--;
          scm_c_frame_previous (kind, frame);
        }
    }
  else
    {
      /* Cut until the given prompt tag is seen. */
      scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
      for (; len; len--, scm_c_frame_previous (kind, frame))
        if (fp_offset == frame->fp_offset)
          break;
    }

  /* Cut outer part. */
  if (scm_is_true (scm_procedure_p (outer_cut)))
    {
      long i, new_len;
      struct scm_frame tmp;

      memcpy (&tmp, frame, sizeof tmp);

      /* Cut until the given procedure is seen. */
      for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
        if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
          new_len = i;

      len = new_len;
    }
  else if (scm_is_pair (outer_cut)
           && scm_is_integer (scm_car (outer_cut))
           && scm_is_integer (scm_cdr (outer_cut)))
    {
      /* Cut until an IP within the given range is found.  */
      scm_t_uintptr low_pc, high_pc, pc;
      long i, new_len;
      struct scm_frame tmp;

      low_pc = scm_to_uintptr_t (scm_car (outer_cut));
      high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));

      memcpy (&tmp, frame, sizeof tmp);

      /* Cut until the given procedure is seen. */
      for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
        {
          pc = (scm_t_uintptr) tmp.ip;
          if (low_pc <= pc && pc < high_pc)
            new_len = i;
        }

      len = new_len;
    }
  else if (scm_is_integer (outer_cut))
    {
      /* Cut specified number of frames. */
      long outer = scm_to_int (outer_cut);
      
      if (outer < len)
        len -= outer;
      else
        len = 0;
    }
  else
    {
      /* Cut until the given prompt tag is seen. */
      long i;
      struct scm_frame tmp;
      scm_t_ptrdiff fp_offset = find_prompt (outer_cut);

      memcpy (&tmp, frame, sizeof tmp);

      for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
        if (tmp.fp_offset == fp_offset)
          break;

      if (i < len)
        len = i;
      else
        len = 0;
    }

  return len;
}