C++ scm_is_true函数代码示例

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