C++ SCM_CAR函数代码示例

static void
scm_scmlist_print (LONGEST svalue, struct ui_file *stream, int format,
		   int deref_ref, int recurse, enum val_prettyprint pretty)
{
  unsigned int more = print_max;
  if (recurse > 6)
    {
      fputs_filtered ("...", stream);
      return;
    }
  scm_scmval_print (SCM_CAR (svalue), stream, format,
		    deref_ref, recurse + 1, pretty);
  svalue = SCM_CDR (svalue);
  for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue))
    {
      if (SCM_NECONSP (svalue))
	break;
      fputs_filtered (" ", stream);
      if (--more == 0)
	{
	  fputs_filtered ("...", stream);
	  return;
	}
      scm_scmval_print (SCM_CAR (svalue), stream, format,
			deref_ref, recurse + 1, pretty);
    }
  if (SCM_NNULLP (svalue))
    {
      fputs_filtered (" . ", stream);
      scm_scmval_print (svalue, stream, format,
			deref_ref, recurse + 1, pretty);
    }
}

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

SWIGINTERN int
SWIG_Guile_GetArgs (SCM *dest, SCM rest,
		    int reqargs, int optargs,
		    const char *procname)
{
  int i;
  int num_args_passed = 0;
  for (i = 0; i<reqargs; i++) {
    if (!SCM_CONSP(rest))
      scm_wrong_num_args(scm_from_locale_string((char *) procname));
    *dest++ = SCM_CAR(rest);
    rest = SCM_CDR(rest);
    num_args_passed++;
  }
  for (i = 0; i<optargs && SCM_CONSP(rest); i++) {
    *dest++ = SCM_CAR(rest);
    rest = SCM_CDR(rest);
    num_args_passed++;
  }
  for (; i<optargs; i++)
    *dest++ = SCM_UNDEFINED;
  if (!SCM_NULLP(rest))
    scm_wrong_num_args(scm_from_locale_string((char *) procname));
  return num_args_passed;
}

/********************************************************************
 * update_report_list
 *
 * this procedure does the real work of displaying a sorted list of
 * available custom reports
 ********************************************************************/
static void
update_report_list(GtkListStore *store, CustomReportDialog *crd)
{
    SCM get_rpt_guids = scm_c_eval_string("gnc:custom-report-template-guids");
    SCM template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
    SCM rpt_guids;
    int i;
    GtkTreeIter iter;
    GtkTreeModel *model = GTK_TREE_MODEL (store);
    gboolean valid_iter;

    gtk_tree_sortable_set_sort_column_id(GTK_TREE_SORTABLE(store), COL_NAME, GTK_SORT_ASCENDING);

    crd->reportlist = scm_call_0(get_rpt_guids);
    rpt_guids = crd->reportlist;

    /* Empty current liststore */
    valid_iter = gtk_tree_model_get_iter_first (model, &iter);
    while (valid_iter)
    {
        GValue value = { 0, };
        GncGUID *row_guid;
        g_value_init ( &value, G_TYPE_POINTER);
        gtk_tree_model_get_value (model, &iter, COL_NUM, &value);
        row_guid = (GncGUID *) g_value_get_pointer (&value);
        guid_free (row_guid);
        g_value_unset (&value);
        valid_iter = gtk_tree_model_iter_next (model, &iter);
    }
    gtk_list_store_clear(store);

    if (scm_is_list(rpt_guids))
    {
        /* for all the report guids in the list, store them, with a reference,
        	 in the gtkliststore */
        for (i = 0; !scm_is_null(rpt_guids); i++)
        {
            GncGUID *guid = guid_malloc ();
            gchar *guid_str = scm_to_utf8_string (SCM_CAR(rpt_guids));
            gchar *name = gnc_scm_to_utf8_string (scm_call_2(template_menu_name, SCM_CAR(rpt_guids), SCM_BOOL_F));

            if (string_to_guid (guid_str, guid))
            {
                gtk_list_store_append(store, &iter);
                gtk_list_store_set(store, &iter,
                                   COL_NAME, name,
                                   COL_NUM, guid,
                                   -1);
            }
            g_free (name);
            g_free (guid_str);

            rpt_guids = SCM_CDR(rpt_guids);
        }
    }
}

GList *
gnc_scm_list_to_glist(SCM rest)
{
    GList *result = NULL;
    SCM scm_item;

    SWIG_GetModule(NULL); /* Work-around for SWIG bug. */
    SCM_ASSERT(scm_is_list(rest), rest, SCM_ARG1, "gnc_scm_list_to_glist");

    while (!scm_is_null(rest))
    {
        void *item;

        scm_item = SCM_CAR(rest);
        rest = SCM_CDR(rest);

        if (scm_item == SCM_BOOL_F)
        {
            result = g_list_prepend(result, NULL);
        }
        else
        {
            if (!SWIG_IsPointer(scm_item))
                scm_misc_error("gnc_scm_list_to_glist",
                               "Item in list not a wcp.", scm_item);

            item = (void *)SWIG_PointerAddress(scm_item);
            result = g_list_prepend(result, item);
        }
    }

    return g_list_reverse(result);
}

GncAccountValue * gnc_scm_to_account_value_ptr (SCM valuearg)
{
    GncAccountValue *res;
    Account *acc = NULL;
    gnc_numeric value;
    swig_type_info * account_type = get_acct_type();
    SCM val;

    /* Get the account */
    val = SCM_CAR (valuearg);
    if (!SWIG_IsPointerOfType (val, account_type))
        return NULL;

    acc = SWIG_MustGetPtr(val, account_type, 1, 0);

    /* Get the value */
    val = SCM_CDR (valuearg);
    value = gnc_scm_to_numeric (val);

    /* Build and return the object */
    res = g_new0 (GncAccountValue, 1);
    res->account = acc;
    res->value = value;
    return res;
}

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 make_doc(SCM ingredients, SCM recipe) {
	MAKE_NODE *node;
	FILE_NODE *fnode;
	SCM smob, cursor;
	if (scm_is_symbol(ingredients)) {
		if (ingredients == file_sym) {
			node = make_node(TYPE_FILE);
			node->filepath = scm_to_locale_string(recipe);
			node->dirty = 1;
			fnode = (FILE_NODE *)malloc(sizeof(FILE_NODE));
			fnode->node = node;
			fnode->mtime = 0;
			fnode->next = file_nodes;
			file_nodes = fnode;
			}
		else {
			node = make_node(TYPE_DATUM);
			node->dirty = 0;
			node->payload = recipe;
			}
		SCM_RETURN_NEWSMOB(make_node_tag, node);
		}
	node = make_node(TYPE_CHAIN);
	node->dirty = 1;
	node->callback = recipe;
	SCM_NEWSMOB(smob, make_node_tag, node);
	cursor = ingredients;
	while (cursor != SCM_EOL) {
		add_ascendant(SCM_CAR(cursor), smob);
		cursor = SCM_CDR(cursor);
		}
	scm_remember_upto_here_2(ingredients, recipe);
	scm_remember_upto_here_2(smob, cursor);
	return smob;
	}

static SCM
decode_scm_col_list (GttGhtml *ghtml, SCM col_list)
{
	SCM col_name;
	char * tok = NULL;

	/* reset the parser */
	ghtml->ninvl_cols = 0;
	ghtml->ntask_cols = 0;
		
	while (!scm_is_null (col_list))
	{
		col_name = SCM_CAR (col_list);

		/* either a 'symbol or a "quoted string" */
		if (!scm_is_symbol(col_name) && !scm_is_string (col_name))
		{
			col_list = SCM_CDR (col_list);
			continue;
		}
		tok = scm_to_locale_string (col_name);
		decode_column (ghtml, tok);

		free (tok);
		col_list = SCM_CDR (col_list);
	}

	return SCM_UNSPECIFIED;
}

/* ADDRS is a list of socket addresses; if 'from' address type matches
   one of them, it is used to store the information so that we can avoid
   allocation.  If no addresses match the incoming type, and ADDRS is
   a complete list, the information of 'from' is discarded.  If no addresses
   match the incoming type, and the last cdr of ADDRS is #t (this case
   includes ADDRS == #t), a new sockaddr is allocated and returned. */
ScmObj Scm_SocketRecvFromX(ScmSocket *sock, ScmUVector *buf,
                           ScmObj addrs, int flags)
{
    int r;
    u_int size;
    struct sockaddr_storage from;
    socklen_t fromlen = sizeof(from);
    ScmObj addr = SCM_FALSE;

    CLOSE_CHECK(sock->fd, "recv from", sock);
    char *z = get_message_buffer(buf, &size);
    SCM_SYSCALL(r, recvfrom(sock->fd, z, size, flags,
                            (struct sockaddr*)&from, &fromlen));
    if (r < 0) {
        Scm_SysError("recvfrom(2) failed");
    }
    ScmObj cp;
    SCM_FOR_EACH(cp, addrs) {
        ScmObj a = SCM_CAR(cp);
        if (Scm_SockAddrP(a)) {
            if (SCM_SOCKADDR_FAMILY(a) == from.ss_family) {
                memcpy(&SCM_SOCKADDR(a)->addr, &from, SCM_SOCKADDR(a)->addrlen);
                addr = a;
                break;
            }
        }
    }

ScmObj Scm_CopyList(ScmObj list)
{
    if (!SCM_PAIRP(list)) return list;

    ScmObj start = SCM_NIL, last = SCM_NIL;
    SCM_FOR_EACH(list, list) {
        SCM_APPEND1(start, last, SCM_CAR(list));
    }

/*! \todo Finish function documentation!!!
 *  \brief
 *  \par Function Description
 *
 */
SCM g_funcs_filesel(SCM scm_msg, SCM scm_templ, SCM scm_flags)
{
  int c_flags;
  char *r, *msg, *templ;
  SCM v;

  SCM_ASSERT (scm_is_string (scm_msg), scm_msg,
	      SCM_ARG1, "gschem-filesel");
  
  SCM_ASSERT (scm_is_string (scm_templ), scm_templ,
	      SCM_ARG2, "gschem-filesel");
  
  /*! \bug FIXME -- figure out the magic SCM_ASSERT for the flags */

  /*! \bug FIXME -- how to deal with conflicting flags? 
   * Should I throw a scheme error?  Just deal in the c code?
   */
  for (c_flags = 0; scm_is_pair (scm_flags); scm_flags = SCM_CDR (scm_flags)) {
    char *flag;
    SCM scm_flag = SCM_CAR (scm_flags);

    flag = scm_to_utf8_string (scm_flag);
    if (strcmp (flag, "may_exist") == 0) {
      c_flags |= FSB_MAY_EXIST;

    } else if (strcmp (flag, "must_exist") == 0) {
      c_flags |= FSB_MUST_EXIST;
      
    } else if (strcmp (flag, "must_not_exist") == 0) {
      c_flags |= FSB_SHOULD_NOT_EXIST;

    } else if (strcmp (flag, "save") == 0) {
      c_flags |= FSB_SAVE;

    } else if (strcmp (flag, "open") == 0) {
      c_flags |= FSB_LOAD;

    } else {
      free(flag);
      scm_wrong_type_arg ("gschem-filesel", SCM_ARG3, scm_flag);
    }
    free(flag);
  }

  msg = scm_to_utf8_string (scm_msg);
  templ = scm_to_utf8_string (scm_templ);

  r = generic_filesel_dialog (msg, templ, c_flags);

  free(msg);
  free(templ);

  v = scm_from_utf8_string (r);
  g_free (r);

  return v;
}

/* FIXME: needs comment: */
static void
scm_ipruk(const char *hdr, LONGEST ptr, struct ui_file *stream)
{
  fprintf_filtered(stream, "#<unknown-%s", hdr);
#define SCM_SIZE TYPE_LENGTH(builtin_type_scm)
  if (SCM_CELLP(ptr))
    fprintf_filtered(stream, " (0x%lx . 0x%lx) @",
		     (long)SCM_CAR(ptr), (long)SCM_CDR(ptr));
  fprintf_filtered(stream, " 0x%s>", paddr_nz(ptr));
}

/*=gfunc in_p
 *
 * what:   test for string in list
 * general_use:
 * exparg: test-string, string to look for
 * exparg: string-list, list of strings to check,, list
 *
 * doc:  Return SCM_BOOL_T if the first argument string is found
 *      in one of the entries in the second (list-of-strings) argument.
=*/
SCM
ag_scm_in_p(SCM obj, SCM list)
{
    int     len;
    size_t  lenz;
    SCM     car;
    char const * pz1;

    if (! AG_SCM_STRING_P(obj))
        return SCM_UNDEFINED;

    pz1  = scm_i_string_chars(obj);
    lenz = AG_SCM_STRLEN(obj);

    /*
     *  If the second argument is a string somehow, then treat
     *  this as a straight out string comparison
     */
    if (AG_SCM_STRING_P(list)) {
        if (  (AG_SCM_STRLEN(list) == lenz)
           && (strncmp(pz1, scm_i_string_chars(list), lenz) == 0))
            return SCM_BOOL_T;
        return SCM_BOOL_F;
    }

    len = (int)scm_ilength(list);
    if (len == 0)
        return SCM_BOOL_F;

    /*
     *  Search all the lists and sub-lists passed in
     */
    while (len-- > 0) {
        car  = SCM_CAR(list);
        list = SCM_CDR(list);

        /*
         *  This routine is listed as getting a list as the second
         *  argument.  That means that if someone builds a list and
         *  hands it to us, it magically becomes a nested list.
         *  This unravels that.
         */
        if (! AG_SCM_STRING_P(car)) {
            if (ag_scm_in_p(obj, car) == SCM_BOOL_T)
                return SCM_BOOL_T;
            continue;
        }

        if (  (AG_SCM_STRLEN(car) == lenz)
           && (strncmp(pz1, scm_i_string_chars(car), lenz) == 0) )
            return SCM_BOOL_T;
    }

    return SCM_BOOL_F;
}

static SCM
scm_i_vector2list (SCM l, long len)
{
  long j;
  SCM z = scm_c_make_vector (len, SCM_UNDEFINED);

  for (j = 0; j < len; j++, l = SCM_CDR (l)) {
    SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
  }
  return z;
}