static void
game_process_event (Game *game)
{
    static ALLEGRO_EVENT event;

    al_wait_for_event(game->event_queue, &event);

    if (event.type == ALLEGRO_EVENT_DISPLAY_CLOSE)
    {
	game->running = false;
    }
    else if (event.type == ALLEGRO_EVENT_TIMER)
    {
	game_update (game);
    }
    else if (event.type == ALLEGRO_EVENT_KEY_UP)
    {
	if (scm_is_true (game->on_key_released))
	{
	    scm_call_1 (game->on_key_released, scm_from_int (event.keyboard.keycode));
	}
    }
    else if (event.type == ALLEGRO_EVENT_KEY_DOWN)
    {
	if (scm_is_true (game->on_key_pressed))
	{
	    scm_call_1 (game->on_key_pressed, scm_from_int (event.keyboard.keycode));
	}
    }
}

static void 
syntax_error (const char* const msg, const SCM form, const SCM expr)
{
  SCM msg_string = scm_from_locale_string (msg);
  SCM filename = SCM_BOOL_F;
  SCM linenr = SCM_BOOL_F;
  const char *format;
  SCM args;

  if (scm_is_pair (form))
    {
      filename = scm_source_property (form, scm_sym_filename);
      linenr = scm_source_property (form, scm_sym_line);
    }

  if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
    {
      filename = scm_source_property (expr, scm_sym_filename);
      linenr = scm_source_property (expr, scm_sym_line);
    }

  if (!SCM_UNBNDP (expr))
    {
      if (scm_is_true (filename))
	{
	  format = "In file ~S, line ~S: ~A ~S in expression ~S.";
	  args = scm_list_5 (filename, linenr, msg_string, form, expr);
	}
      else if (scm_is_true (linenr))
	{
	  format = "In line ~S: ~A ~S in expression ~S.";
	  args = scm_list_4 (linenr, msg_string, form, expr);
	}
      else
	{
	  format = "~A ~S in expression ~S.";
	  args = scm_list_3 (msg_string, form, expr);
	}
    }
  else
    {
      if (scm_is_true (filename))
	{
	  format = "In file ~S, line ~S: ~A ~S.";
	  args = scm_list_4 (filename, linenr, msg_string, form);
	}
      else if (scm_is_true (linenr))
	{
	  format = "In line ~S: ~A ~S.";
	  args = scm_list_3 (linenr, msg_string, form);
	}
      else
	{
	  format = "~A ~S.";
	  args = scm_list_2 (msg_string, form);
	}
    }

  scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
}

static SCM
expand_eval_when (SCM expr, SCM env)
{
  ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);

  if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
      || scm_is_true (scm_memq (sym_load, CADR (expr))))
    return expand_sequence (CDDR (expr), env);
  else
    return VOID (scm_source_properties (expr));
}

static SCM
expand_env_ref_macro (SCM env, SCM x)
{
  SCM var;
  if (!expand_env_var_is_free (env, x))
    return SCM_BOOL_F; /* lexical */

  var = scm_module_variable (scm_current_module (), x);
  if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
      && scm_is_true (scm_macro_p (scm_variable_ref (var))))
    return scm_variable_ref (var);
  else
    return SCM_BOOL_F; /* anything else */
}

int test_cl_is_handle_p__handle (void)
{
  SCM handle = cl_easy_init();
  SCM ret = cl_is_handle_p(handle);
  printf("test that cl_is_handle_p returns #t when passed a handle: %d\n", ret);
  return scm_is_true(ret);
}

/*! \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;
}

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;
}

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
game_run (SCM game_smob)
{
    Game *game = check_game (game_smob);

    if (scm_is_true (game->on_start)) {
	scm_call_0 (game->on_start);
    }

    al_start_timer (game->timer);
    game->last_update_time = al_get_time ();

    while (game->running) {
	game_process_event (game);

	if (game->redraw && al_is_event_queue_empty (game->event_queue)) {
	    game->redraw = false;
	    game_draw (game);
	}
    }

    game_destroy (game);

    return SCM_UNSPECIFIED;
}

SCM
gfec_eval_string(const char *str, gfec_error_handler error_handler)
{
    SCM result = SCM_UNDEFINED;
    SCM func = scm_c_eval_string("gnc:eval-string-with-error-handling");
    if (scm_is_procedure(func))
    {
        char *err_msg = NULL;
        SCM call_result, error = SCM_UNDEFINED;
        call_result = scm_call_1 (func, scm_from_utf8_string (str));

        error = scm_list_ref (call_result, scm_from_uint (1));
        if (scm_is_true (error))
            err_msg = gnc_scm_to_utf8_string (error);
        else
            result = scm_list_ref (call_result, scm_from_uint (0));

        if (err_msg != NULL)
        {
            if (error_handler)
                error_handler (err_msg);

            free(err_msg);
        }
    }

    return result;
}

static Expr* not(Expr* args) {
	assert(args);
	
	if(scm_list_len(args) != 1) return scm_mk_error("not expects 1 arg");

	return scm_is_true(scm_car(args)) ? FALSE : TRUE;
}

/********************************************************************\
 * gnc_is_trans_scm                                                 *
 *   returns true if the scm object is a scheme transaction         *
 *                                                                  *
 * Args: scm - a scheme object                                      *
 * Returns: true if scm is a scheme transaction                     *
\********************************************************************/
gboolean
gnc_is_trans_scm(SCM scm)
{
    initialize_scm_functions();

    return scm_is_true(scm_call_1(predicates.is_trans_scm, scm));
}

SCM
gfec_apply(SCM proc, SCM arglist, gfec_error_handler error_handler)
{
    SCM result = SCM_UNDEFINED;
    SCM func = scm_c_eval_string("gnc:apply-with-error-handling");
    if (scm_is_procedure(func))
    {
        char *err_msg = NULL;
        SCM call_result, error;
        call_result = scm_call_2 (func, proc, arglist);

        error = scm_list_ref (call_result, scm_from_uint (1));
        if (scm_is_true (error))
            err_msg = gnc_scm_to_utf8_string (error);
        else
            result = scm_list_ref (call_result, scm_from_uint (0));

        if (err_msg != NULL)
        {
            if (error_handler)
                error_handler (err_msg);

            free(err_msg);
        }
    }

    return result;
}

VISIBLE SCM
scm_rexp_number_of_subexpressions (SCM match)
{
  return (scm_is_true (match)) ?
    scm_from_size_t (rexp_num_subexpr (scm_to_rexp_match_t (match))) :
    scm_from_int (0);
}

static SCM
guile_sock_no_delay (SCM sock, SCM enable)
{
    svz_socket_t *xsock;
    int old = 0, set = 0;

    scm_assert_smob_type (guile_svz_socket_tag, sock);
    xsock = (svz_socket_t *) SCM_SMOB_DATA (sock);
    if (xsock->proto & PROTO_TCP)
    {
        if (!SCM_UNBNDP (enable))
        {
            SCM_ASSERT (scm_is_bool (enable) || scm_is_integer (enable), enable,
                        SCM_ARG2, FUNC_NAME);
            if ((scm_is_bool (enable) && scm_is_true (enable)) ||
                    (scm_is_integer (enable) && scm_to_int (enable) != 0))
                set = 1;
        }
        if (svz_tcp_nodelay (xsock->sock_desc, set, &old) < 0)
            old = 0;
        else if (SCM_UNBNDP (enable))
            svz_tcp_nodelay (xsock->sock_desc, old, NULL);
    }
    return SCM_BOOL (old);
}

/*! \brief Process a Scheme error into the log and/or a GError
 * \par Function Description
 * Process a captured Guile exception with the given \a s_key and \a
 * s_args, and optionally the stack trace \a s_stack.  The stack trace
 * and source location are logged, and if a GError return location \a
 * err is provided, it is populated with an informative error message.
 */
static void
process_error_stack (SCM s_stack, SCM s_key, SCM s_args, GError **err) {
  char *long_message;
  char *short_message;
  SCM s_port, s_subr, s_message, s_message_args, s_rest, s_location;

  /* Split s_args up */
  s_rest = s_args;
  s_subr = scm_car (s_rest);         s_rest = scm_cdr (s_rest);
  s_message = scm_car (s_rest);      s_rest = scm_cdr (s_rest);
  s_message_args = scm_car (s_rest); s_rest = scm_cdr (s_rest);

  /* Capture short error message */
  s_port = scm_open_output_string ();
  scm_display_error_message (s_message, s_message_args, s_port);
  short_message = scm_to_utf8_string (scm_get_output_string (s_port));
  scm_close_output_port (s_port);

  /* Capture long error message (including possible backtrace) */
  s_port = scm_open_output_string ();
  if (scm_is_true (scm_stack_p (s_stack))) {
    scm_puts (_("\nBacktrace:\n"), s_port);
    scm_display_backtrace (s_stack, s_port, SCM_BOOL_F, SCM_BOOL_F);
    scm_puts ("\n", s_port);
  }

  s_location = SCM_BOOL_F;
#ifdef HAVE_SCM_DISPLAY_ERROR_STACK
  s_location = s_stack;
#endif /* HAVE_SCM_DISPLAY_ERROR_STACK */
#ifdef HAVE_SCM_DISPLAY_ERROR_FRAME
  s_location =
    scm_is_true (s_stack) ? scm_stack_ref (s_stack, SCM_INUM0) : SCM_BOOL_F;
#endif /* HAVE_SCM_DISPLAY_ERROR_FRAME */

  scm_display_error (s_location, s_port, s_subr,
                     s_message, s_message_args, s_rest);

  long_message = scm_to_utf8_string (scm_get_output_string (s_port));
  scm_close_output_port (s_port);

  /* Send long message to log */
  s_log_message ("%s", long_message);

  /* Populate any GError */
  g_set_error (err, EDA_ERROR, EDA_ERROR_SCHEME, "%s", short_message);
}

static SCM
expand (SCM exp, SCM env)
{
  if (scm_is_pair (exp))
    {
      SCM car;
      scm_t_macro_primitive trans = NULL;
      SCM macro = SCM_BOOL_F;
      
      car = CAR (exp);
      if (scm_is_symbol (car))
        macro = expand_env_ref_macro (env, car);
      
      if (scm_is_true (macro))
        trans = scm_i_macro_primitive (macro);

      if (trans)
        return trans (exp, env);
      else
        {
          SCM arg_exps = SCM_EOL;
          SCM args = SCM_EOL;
          SCM proc = CAR (exp);
          
          for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
               arg_exps = CDR (arg_exps))
            args = scm_cons (expand (CAR (arg_exps), env), args);
          if (scm_is_null (arg_exps))
            return CALL (scm_source_properties (exp),
                         expand (proc, env),
                         scm_reverse_x (args, SCM_UNDEFINED));
          else
            syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
        }
    }
  else if (scm_is_symbol (exp))
    {
      SCM gensym = expand_env_lexical_gensym (env, exp);
      if (scm_is_true (gensym))
        return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
      else
        return TOPLEVEL_REF (SCM_BOOL_F, exp);
    }
  else
    return CONST (SCM_BOOL_F, exp);
}

SCM tf_set_attr_bool(SCM scm_description, SCM scm_name, SCM scm_value)
{
  struct tf_description_t *self = get_tf_description(scm_description);
  char *name = scm_to_locale_string(scm_name);
  TF_SetAttrBool(self->description, name, scm_is_true(scm_value));
  free(name);
  return SCM_UNDEFINED;
}

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;
}

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;
}