예제 #1
0
파일: error.c 프로젝트: Z-Shang/Gauche
static ScmObj message_prefix_get(ScmMessageCondition *obj)
{
    ScmObj msglist = obj->message;
    if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
        return SCM_CADR(msglist);
    } else {
        return msglist;
    }
}
예제 #2
0
파일: pyscm.c 프로젝트: tddpirate/pyguile
static PyObject *
pyscm_PySCM_call(pyscm_PySCMObject *self, PyObject *args, PyObject *kwargs)
{
  /* Return the result of calling self with argument args */

  SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(self->ob_scm_index));
  if (SCM_BOOLP(shandle) && SCM_EQ_P(SCM_BOOL_F,shandle)) {
    Py_FatalError("PySCM object lost its associated SCM object");  // NOT COVERED BY TESTS
  }
  // Now:
  // SCM_CADR(shandle) is the SCM object itself
  // SCM_CDDR(shandle) is the stemplate.
  if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
    scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_call: calling ~S with args=~S and keywords=~S; stemplate=~S\n"),scm_list_4(SCM_CADR(shandle),verbosity_repr(args),verbosity_repr(kwargs),SCM_CDDR(shandle)));
  }

  SCM sapply_func = GET_APPLY_FUNC(SCM_CDDR(shandle));
  if (SCM_EQ_P(SCM_EOL,sapply_func)) {
    if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
      scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_call: raising exceptions.TypeError due to \"PySCM wraps a non-callable SCM\"\n"),SCM_EOL);
    }
    PyErr_SetString(PyExc_TypeError, "PySCM wraps a non-callable SCM");
    return(NULL);
  }

  // Process arguments.
  SCM sargs_template = GET_P2G_POSITIONAL_ARGS_TEMPLATE(SCM_CDDR(shandle));
  SCM skwargs_template = GET_P2G_KEYWORD_ARGS_TEMPLATE(SCM_CDDR(shandle));
  /*if (logical_xor(SCM_EQ_P(SCM_EOL,sargs_template),(NULL==args))
    || logical_xor(SCM_EQ_P(SCM_EOL,skwargs_template),(NULL==kwargs)))*/
  // The following allows template to exist without actual arguments.
  if ((SCM_EQ_P(SCM_EOL,sargs_template) && (NULL != args))
      || (SCM_EQ_P(SCM_EOL,skwargs_template) && (NULL != kwargs))) {
    if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
      scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_call: raising exceptions.TypeError due to \"wrapped SCM does not take some of the provided arguments\"\n"),SCM_EOL);
    }
    PyErr_SetString(PyExc_TypeError, "wrapped SCM does not take some of the provided arguments");
    return(NULL);
  }

  SCM sargs = SCM_EQ_P(SCM_EOL,sargs_template) || (NULL == args)
    ? SCM_EOL : p2g_apply(args,sargs_template);
  SCM skwargs = SCM_EQ_P(SCM_EOL,skwargs_template) || (NULL == kwargs)
    ? SCM_EOL : p2g_apply(kwargs,skwargs_template);

  SCM sresult = scm_apply(sapply_func,scm_list_2(SCM_CADR(shandle),scm_list_2(sargs,skwargs)),SCM_EOL);
  SCM sresult_template = GET_G2P_RESULT_TEMPLATE(SCM_CDDR(shandle));
  if (SCM_EQ_P(SCM_EOL,sresult_template)) {
    Py_RETURN_NONE;
  }
  else {
    return(g2p_apply(sresult,sresult_template));
  }
}
예제 #3
0
static void
gnc_column_view_edit_size_cb(GtkButton * button, gpointer user_data)
{
    gnc_column_view_edit * r = user_data;
    GtkWidget * rowspin;
    GtkWidget * colspin;
    GtkWidget * dlg;
    GladeXML *xml;
    SCM current;
    int length;
    int dlg_ret;

    xml = gnc_glade_xml_new ("report.glade", "Edit Report Size");
    dlg = glade_xml_get_widget (xml, "Edit Report Size");

    /* get the spinner widgets */
    rowspin = glade_xml_get_widget (xml, "row_spin");
    colspin = glade_xml_get_widget (xml, "col_spin");

    length = scm_ilength(r->contents_list);
    if (length > r->contents_selected)
    {
        current = scm_list_ref(r->contents_list,
                               scm_int2num(r->contents_selected));
        gtk_spin_button_set_value(GTK_SPIN_BUTTON(colspin),
                                  (float)scm_num2int(SCM_CADR(current),
                                          SCM_ARG1, G_STRFUNC));
        gtk_spin_button_set_value(GTK_SPIN_BUTTON(rowspin),
                                  (float)scm_num2int(SCM_CADDR(current),
                                          SCM_ARG1, G_STRFUNC));

        dlg_ret = gtk_dialog_run(GTK_DIALOG(dlg));
        gtk_widget_hide(dlg);

        if (dlg_ret == GTK_RESPONSE_OK)
        {
            current = SCM_LIST4(SCM_CAR(current),
                                scm_int2num(gtk_spin_button_get_value_as_int
                                            (GTK_SPIN_BUTTON(colspin))),
                                scm_int2num(gtk_spin_button_get_value_as_int
                                            (GTK_SPIN_BUTTON(rowspin))),
                                SCM_BOOL_F);
            scm_gc_unprotect_object(r->contents_list);
            r->contents_list = scm_list_set_x(r->contents_list,
                                              scm_int2num(r->contents_selected),
                                              current);
            scm_gc_protect_object(r->contents_list);
            gnc_options_dialog_changed (r->optwin);
            update_display_lists(r);
        }
        gtk_widget_destroy(dlg);
    }
}
예제 #4
0
파일: pyscm.c 프로젝트: tddpirate/pyguile
// Unwrap a pyscm_PySCMObject instance and get from it the original
// SCM object.  If the object is not a pyscm_PySCMObject or does not
// wrap a SCM object, raise an error.
SCM
unwrap_pyscm_object(PyObject *pobj)
{
  if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
    scm_simple_format(scm_current_output_port(),scm_makfrom0str("# unwrap_pyscm_object: trying to unwrap pobj=~S\n"),scm_list_1(verbosity_repr(pobj)));
  }

  if (!PySCMObject_Check(pobj)) {
    Py_FatalError("Trying to pyscm-unwrap a non-PySCM");
  }
  SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(((pyscm_PySCMObject *)pobj)->ob_scm_index));
  return(SCM_CADR(shandle));
}
예제 #5
0
파일: symbol.c 프로젝트: Z-Shang/Gauche
ScmObj Scm_GetKeyword(ScmObj key, ScmObj list, ScmObj fallback)
{
    ScmObj cp;
    SCM_FOR_EACH(cp, list) {
        if (!SCM_PAIRP(SCM_CDR(cp))) {
            Scm_Error("incomplete key list: %S", list);
        }
        if (key == SCM_CAR(cp)) return SCM_CADR(cp);
        cp = SCM_CDR(cp);
    }
    if (SCM_UNBOUNDP(fallback)) {
        Scm_Error("value for key %S is not provided: %S", key, list);
    }
    return fallback;
}
예제 #6
0
파일: values.c 프로젝트: jockej/guile4emacs
/* OBJ must be a values object containing exactly two values.
   scm_i_extract_values_2 puts those two values into *p1 and *p2.  */
void
scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
{
  SCM values;

  SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1,
		   "scm_i_extract_values_2", "values");
  values = scm_struct_ref (obj, SCM_INUM0);
  if (scm_ilength (values) != 2)
    scm_wrong_type_arg_msg
      ("scm_i_extract_values_2", SCM_ARG1, obj,
       "a values object containing exactly two values");
  *p1 = SCM_CAR (values);
  *p2 = SCM_CADR (values);
}
예제 #7
0
파일: pyscm.c 프로젝트: tddpirate/pyguile
// Does not include the template object in the string representation.
static PyObject *
pyscm_PySCM_str(pyscm_PySCMObject *self)
{
  if (0 == self->ob_scm_index) {
    return(PyString_FromString("<no SCM association>"));
  }
  SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(self->ob_scm_index));
  if (SCM_BOOLP(shandle) && SCM_EQ_P(SCM_BOOL_F,shandle)) {
    Py_FatalError("PySCM object lost its associated SCM object");
  }
  SCM sstr = scm_object_to_string(SCM_CADR(shandle),scm_variable_ref(scm_c_lookup("write")));

  PyObject *pstr = PyString_FromStringAndSize(SCM_STRING_CHARS(sstr),SCM_STRING_LENGTH(sstr));
  return(pstr);  // possibly NULL.
}
예제 #8
0
파일: pyscm.c 프로젝트: tddpirate/pyguile
// Common code for pyscm_PySCM_getattr() and pyscm_PySCM_setattr():
// Retrieve and return the 4-element vector corresponding to desired
// attribute of the pyscm_PySCMObject.
// Perform also validity checking and raise Python exception if
// invalid.
// Since it is needed later, also the SCM object, corresponding to the
// pyscm_PySCMObject, is returned to the caller, put into 2-element
// list together with the #:-keyword corresponding to name.
static SCM
retrieve_sattr_vector(pyscm_PySCMObject *self, char *name, SCM *sobj_keyword)
{
  SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(self->ob_scm_index));
  if (SCM_BOOLP(shandle) && SCM_EQ_P(SCM_BOOL_F,shandle)) {
    Py_FatalError("PySCM object lost its associated SCM object");
  }
  // Now:
  // SCM_CADR(shandle) is the SCM object itself
  // SCM_CDDR(shandle) is the stemplate.
  SCM sattrshash = GET_ATTRS_HASH(SCM_CDDR(shandle));

  if (SCM_EQ_P(SCM_BOOL_F,sattrshash)) {
    PyErr_SetString(PyExc_AttributeError, name);
    return(SCM_UNDEFINED);  // Error return
  }

  // The object has attributes.  Build the hash key (a keyword).

  size_t nlength = strlen(name);
  char *dashstr = malloc(nlength+2);
  dashstr[0] = '-';
  dashstr[1] = '\0';
  strncat(dashstr,name,nlength);
  SCM skeyword = scm_make_keyword_from_dash_symbol(scm_str2symbol(dashstr));
  // !!! Do we have to free dashstr?
  // !!! Similar code is used also in pytoguile.c - review it.

  SCM sattr_vector_handle = scm_hashv_get_handle(sattrshash,skeyword);
  if (SCM_EQ_P(SCM_BOOL_F,sattr_vector_handle)) {
    // Missing attribute.  How to deal with it?
    sattr_vector_handle = scm_hashv_get_handle(sattrshash,SCM_BOOL_F);
    if (SCM_EQ_P(SCM_BOOL_F,sattr_vector_handle)) {
      // Hash value corresponding to key #f is itself another #f, which
      // means that the object does not wish to exhibit to Python
      // unknown attributes.
      PyErr_SetString(PyExc_AttributeError, name);
      return(SCM_UNDEFINED);  // Error return
    }
    // Otherwise, we'll use the hash value corresponding to #f as
    // a catch-all for all attributes not otherwise defined.
  }
  *sobj_keyword = scm_list_2(SCM_CADR(shandle),skeyword);
  return(SCM_CDR(sattr_vector_handle));
}
예제 #9
0
파일: guile_tm.hpp 프로젝트: mgubi/texmacs
inline tmscm tmscm_cadr (tmscm obj) { return SCM_CADR (obj); }
예제 #10
0
파일: write.c 프로젝트: h2oota/Gauche
/* Trick: The hashtable contains positive integer after the walk pass.
   If we emit a reference tag N, we replace the entry's value to -N,
   so that we can distinguish whether we've already emitted the object
   or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
    char numbuf[50];  /* enough to contain long number */
    ScmObj stack = SCM_NIL;
    ScmWriteState *st = port->writeState;
    ScmHashTable *ht = (st? st->sharedTable : NULL);
    int stack_depth = 0;

#define PUSH(elt)                                       \
    do {                                                \
        stack = Scm_Cons(elt, stack);                   \
        if (!ht && ++stack_depth > STACK_LIMIT) {       \
            Scm_Error("write recursed too deeply; "     \
                      "maybe a circular structure?");   \
        }                                               \
    } while (0)
#define POP()                                   \
    do {                                        \
        stack = SCM_CDR(stack);                 \
        if (ht) stack_depth--;                  \
    } while (0)

    for (;;) {
    write1:
        if (ctx->flags & WRITE_LIMITED) {
            if (port->src.ostr.length >= ctx->limit) return;
        }

        /* number may be heap allocated, but we don't use srfi-38 notation. */
        if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
            if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
                Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
            }
            goto next;
        }
        if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
            || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
            /* we don't put a reference tag for these */
            write_general(obj, port, ctx);
            goto next;
        }

        if (ht) {
            ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
            long k = SCM_INT_VALUE(e);
            if (k <= 0) {
                /* This object is already printed. */
                snprintf(numbuf, 50, "#%ld#", -k);
                Scm_PutzUnsafe(numbuf, -1, port);
                goto next;
            } else if (k > 1) {
                /* This object will be seen again. Put a reference tag. */
                ScmWriteState *s = port->writeState;
                snprintf(numbuf, 50, "#%d=", s->sharedCounter);
                Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
                s->sharedCounter++;
                Scm_PutzUnsafe(numbuf, -1, port);
            }
        }

        /* Writes aggregates */
        if (SCM_PAIRP(obj)) {
            /* special case for quote etc.
               NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
               get infinite recursion for the case like (cdr '#1='#1#). */
            if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
                && (!ht
                    || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
                const char *prefix = NULL;
                if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
                    prefix = "'";
                } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
                    prefix = "`";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
                    prefix = ",";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
                    prefix = ",@";
                }
                if (prefix) {
                    Scm_PutzUnsafe(prefix, -1, port);
                    obj = SCM_CADR(obj);
                    goto write1;
                }
            }

            /* normal case */
            Scm_PutcUnsafe('(', port);
            PUSH(Scm_Cons(SCM_TRUE, SCM_CDR(obj)));
            obj = SCM_CAR(obj);
            goto write1;
        } else if (SCM_VECTORP(obj)) {
            Scm_PutzUnsafe("#(", -1, port);
            PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
            obj = SCM_VECTOR_ELEMENT(obj, 0);
            goto write1;
        } else {
            /* string or user-defined object */
            write_general(obj, port, ctx);
            goto next;
        }

    next:
        while (SCM_PAIRP(stack)) {
            ScmObj top = SCM_CAR(stack);
            SCM_ASSERT(SCM_PAIRP(top));
            if (SCM_INTP(SCM_CAR(top))) {
                /* we're processing a vector */
                ScmObj v = SCM_CDR(top);
                int i = SCM_INT_VALUE(SCM_CAR(top));
                int len = SCM_VECTOR_SIZE(v);

                if (i == len) { /* we've done this vector */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_VECTOR_ELEMENT(v, i);
                    SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
                    goto write1;
                }
            } else {
                /* we're processing a list */
                ScmObj v = SCM_CDR(top);
                if (SCM_NULLP(v)) { /* we've done with this list */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else if (!SCM_PAIRP(v)) {
                    Scm_PutzUnsafe(" . ", -1, port);
                    obj = v;
                    SCM_SET_CDR(top, SCM_NIL);
                    goto write1;
                } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1)))  {
                    /* cdr part is shared */
                    Scm_PutzUnsafe(" . ", -1, port);
                    obj = v;
                    SCM_SET_CDR(top, SCM_NIL);
                    goto write1;
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_CAR(v);
                    SCM_SET_CDR(top, SCM_CDR(v));
                    goto write1;
                }
            }
        }
        break;
    }

#undef PUSH
#undef POP
}
예제 #11
0
static void
update_display_lists(gnc_column_view_edit * view)
{
    SCM   get_names = scm_c_eval_string("gnc:all-report-template-names");
    SCM   template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
    SCM   report_menu_name = scm_c_eval_string("gnc:report-menu-name");
    SCM   names = scm_call_0(get_names);
    SCM   contents =
        gnc_option_db_lookup_option(view->odb, "__general", "report-list",
                                    SCM_BOOL_F);
    SCM   this_report;
    SCM   selection;
    const gchar *name;
    int   row, i, id;
    GtkListStore *store;
    GtkTreeIter iter;
    GtkTreePath *path;
    GtkTreeSelection *tree_selection;


    /* Update the list of available reports (left selection box). */
    row = view->available_selected;

    if (scm_is_list(view->available_list) && !scm_is_null (view->available_list))
    {
        row = MIN (row, scm_ilength (view->available_list) - 1);
        selection = scm_list_ref (view->available_list, scm_int2num (row));
    }
    else
    {
        selection = SCM_UNDEFINED;
    }

    scm_gc_unprotect_object(view->available_list);
    view->available_list = names;
    scm_gc_protect_object(view->available_list);

    store = GTK_LIST_STORE(gtk_tree_view_get_model(view->available));
    gtk_list_store_clear(store);

    if (scm_is_list(names))
    {
        for (i = 0; !scm_is_null(names); names = SCM_CDR(names), i++)
        {
            char * str;

            if (scm_is_equal (SCM_CAR(names), selection))
                row = i;
            scm_dynwind_begin (0); 
            str = scm_to_locale_string (scm_call_2(template_menu_name, SCM_CAR(names),
                                          SCM_BOOL_F));
            name = _(g_strdup (str));
            scm_dynwind_free (str); 
            scm_dynwind_end (); 
            gtk_list_store_append(store, &iter);
            gtk_list_store_set(store, &iter,
                               AVAILABLE_COL_NAME, name,
                               AVAILABLE_COL_ROW, i,
                               -1);
        }

    }

    tree_selection = gtk_tree_view_get_selection(view->available);
    path = gtk_tree_path_new_from_indices(row, -1);
    gtk_tree_selection_select_path(tree_selection, path);
    gtk_tree_path_free(path);


    /* Update the list of selected reports (right selection box). */
    row = view->contents_selected;

    if (scm_is_list(view->contents_list) && !scm_is_null (view->contents_list))
    {
        row = MIN (row, scm_ilength (view->contents_list) - 1);
        selection = scm_list_ref (view->contents_list, scm_int2num (row));
    }
    else
    {
        selection = SCM_UNDEFINED;
    }

    scm_gc_unprotect_object(view->contents_list);
    view->contents_list = contents;
    scm_gc_protect_object(view->contents_list);

    store = GTK_LIST_STORE(gtk_tree_view_get_model(view->contents));
    gtk_list_store_clear(store);
    if (scm_is_list(contents))
    {
        for (i = 0; !scm_is_null(contents); contents = SCM_CDR(contents), i++)
        {
            char * str;

            if (scm_is_equal (SCM_CAR(contents), selection))
                row = i;

            id = scm_num2int(SCM_CAAR(contents), SCM_ARG1, G_STRFUNC);
            this_report = gnc_report_find(id);
            scm_dynwind_begin (0); 
            str = scm_to_locale_string (scm_call_1(report_menu_name, this_report));
            name = _(g_strdup (str));
            scm_dynwind_free (str); 
            scm_dynwind_end (); 

            gtk_list_store_append(store, &iter);
            gtk_list_store_set
            (store, &iter,
             CONTENTS_COL_NAME, name,
             CONTENTS_COL_ROW, i,
             CONTENTS_COL_REPORT_COLS, scm_num2int(SCM_CADR(SCM_CAR(contents)),
                                                   SCM_ARG1, G_STRFUNC),
             CONTENTS_COL_REPORT_ROWS, scm_num2int(SCM_CADDR(SCM_CAR(contents)),
                                                   SCM_ARG1, G_STRFUNC),
             -1);
        }
    }

    tree_selection = gtk_tree_view_get_selection(view->contents);
    path = gtk_tree_path_new_from_indices(row, -1);
    gtk_tree_selection_select_path(tree_selection, path);
    //  gtk_tree_view_scroll_to_cell(view->contents, path, NULL, TRUE, 0.5, 0.0);
    gtk_tree_path_free(path);
}
예제 #12
0
파일: write.c 프로젝트: icicle99/Gauche
/* Trick: The hashtable contains positive integer after the walk pass.
   If we emit a reference tag N, we replace the entry's value to -N,
   so that we can distinguish whether we've already emitted the object
   or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
    char numbuf[50];  /* enough to contain long number */
    ScmObj stack = SCM_NIL;
    ScmWriteState *st = port->writeState;
    ScmHashTable *ht = (st? st->sharedTable : NULL);
    const ScmWriteControls *wp = Scm_GetWriteControls(ctx, st);
    int stack_depth = 0;        /* only used when !ht */

#define PUSH(elt)                                       \
    do {                                                \
        stack = Scm_Cons(elt, stack);                   \
        if (!ht && ++stack_depth > STACK_LIMIT) {       \
            Scm_Error("write recursed too deeply; "     \
                      "maybe a circular structure?");   \
        }                                               \
    } while (0)
#define POP()                                   \
    do {                                        \
        stack = SCM_CDR(stack);                 \
        if (!ht) stack_depth--;                 \
    } while (0)
#define CHECK_LEVEL()                                                   \
    do {                                                                \
        if (st) {                                                       \
            if (wp->printLevel >= 0 && st->currentLevel >= wp->printLevel) { \
                Scm_PutcUnsafe('#', port);                              \
                goto next;                                              \
            } else {                                                    \
                if (st) st->currentLevel++;                             \
            }                                                           \
        }                                                               \
    } while (0)
    

    for (;;) {
    write1:
        if (ctx->flags & WRITE_LIMITED) {
            if (port->src.ostr.length >= ctx->limit) return;
        }

        /* number may be heap allocated, but we don't use srfi-38 notation. */
        if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
            if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
                Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
            }
            goto next;
        }
        if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
            || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
            /* we don't put a reference tag for these */
            write_general(obj, port, ctx);
            goto next;
        }

        /* obj is heap allocated and we may use label notation. */
        if (ht) {
            ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
            long k = SCM_INT_VALUE(e);
            if (k <= 0) {
                /* This object is already printed. */
                snprintf(numbuf, 50, "#%ld#", -k);
                Scm_PutzUnsafe(numbuf, -1, port);
                goto next;
            } else if (k > 1) {
                /* This object will be seen again. Put a reference tag. */
                ScmWriteState *s = port->writeState;
                snprintf(numbuf, 50, "#%d=", s->sharedCounter);
                Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
                s->sharedCounter++;
                Scm_PutzUnsafe(numbuf, -1, port);
            }
        }

        /* Writes aggregates */
        if (SCM_PAIRP(obj)) {

            CHECK_LEVEL();

            /* special case for quote etc.
               NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
               get infinite recursion for the case like (cdr '#1='#1#). */
            if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
                && (!ht
                    || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
                const char *prefix = NULL;
                if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
                    prefix = "'";
                } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
                    prefix = "`";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
                    prefix = ",";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
                    prefix = ",@";
                }
                if (prefix) {
                    Scm_PutzUnsafe(prefix, -1, port);
                    obj = SCM_CADR(obj);
                    goto write1;
                }
            }

            if (wp->printLength == 0) {
                /* in this case we don't print the elements at all, so we need
                   to treat this specially. */
                Scm_PutzUnsafe("(...)", -1, port);
                if (st) st->currentLevel--;
                goto next;
            }

            /* normal case */
            Scm_PutcUnsafe('(', port);
            PUSH(Scm_Cons(SCM_TRUE, Scm_Cons(SCM_MAKE_INT(1), SCM_CDR(obj))));
            obj = SCM_CAR(obj);
            goto write1;
        } else if (SCM_VECTORP(obj)) {

            CHECK_LEVEL();

            if (wp->printLength == 0) {
                /* in this case we don't print the elements at all, so we need
                   to treat this specially. */
                Scm_PutzUnsafe("#(...)", -1, port);
                if (st) st->currentLevel--;
                goto next;
            }
            Scm_PutzUnsafe("#(", -1, port);
            PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
            obj = SCM_VECTOR_ELEMENT(obj, 0);
            goto write1;
        } else if (Scm_ClassOf(obj)->flags & SCM_CLASS_AGGREGATE) {
            CHECK_LEVEL();
            write_general(obj, port, ctx);
            if (st) st->currentLevel--;
            goto next;
        } else {
            write_general(obj, port, ctx);
            goto next;
        }

    next:
        while (SCM_PAIRP(stack)) {
            ScmObj top = SCM_CAR(stack);
            SCM_ASSERT(SCM_PAIRP(top));
            if (SCM_INTP(SCM_CAR(top))) {
                /* we're processing a vector */
                ScmObj v = SCM_CDR(top);
                int i = SCM_INT_VALUE(SCM_CAR(top));
                int len = SCM_VECTOR_SIZE(v);

                if (i == len) { /* we've done this vector */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else if (wp->printLength >= 0 && wp->printLength <= i) {
                    Scm_PutzUnsafe(" ...)", -1, port);
                    POP();
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_VECTOR_ELEMENT(v, i);
                    SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
                    goto write1;
                }
            } else {
                /* we're processing a list */
                SCM_ASSERT(SCM_PAIRP(SCM_CDR(top)));
                long count = SCM_INT_VALUE(SCM_CADR(top));
                ScmObj v = SCM_CDDR(top);
                if (SCM_NULLP(v)) { /* we've done with this list */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else if (!SCM_PAIRP(v)) {
                    /* Improper list.  We treat aggregate types specially,
                       since such object at this position shouldn't increment
                       "level" - its content is regarded as the same level of
                       the current list.
                     */
                    Scm_PutzUnsafe(" . ", -1, port);
                    if (Scm_ClassOf(v)->flags & SCM_CLASS_AGGREGATE) {
                        if (st) st->currentLevel--;
                        write_rec(v, port, ctx);
                        if (st) st->currentLevel++;
                        Scm_PutcUnsafe(')', port);
                        POP();
                    } else {
                        obj = v;
                        SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
                        SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
                        goto write1;
                    }
                } else if (wp->printLength >= 0 && wp->printLength <= count) {
                    /* print-length limit reached */
                    Scm_PutzUnsafe(" ...)", -1, port);
                    POP();
                } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1)))  {
                    /* cdr part is shared */
                    Scm_PutzUnsafe(" . ", -1, port);
                    obj = v;
                    SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
                    SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
                    goto write1;
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_CAR(v);
                    SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
                    SCM_SET_CDR(SCM_CDR(top), SCM_CDR(v));
                    goto write1;
                }
            }
            if (st) st->currentLevel--;
        }
        break;
    }

#undef PUSH
#undef POP
#undef CHECK_DEPTH
}
예제 #13
0
/****************************************************************
 * acct_tree_add_accts
 *
 * Given a Scheme list of accounts, this function populates a
 * GtkTreeStore from them. If the search_name and reference
 * parameters are provided, and an account is found whose full
 * name matches search_name, then a GtkTreeRowReference* will be
 * returned in the reference parameter.
 ****************************************************************/
static void
acct_tree_add_accts(SCM accts,
                    GtkTreeStore *store,
                    GtkTreeIter *parent,
                    const char *base_name,
                    const char *search_name,
                    GtkTreeRowReference **reference)
{
    GtkTreeIter  iter;
    char         * compname;
    char         * acctname;
    gboolean     leafnode;
    SCM          current;
    gboolean     checked;

    while (!scm_is_null(accts))
    {
        current = SCM_CAR(accts);

        if (scm_is_null(current))
        {
            g_critical("QIF import: BUG DETECTED in acct_tree_add_accts!");
            accts = SCM_CDR(accts);
            continue;
        }

        if (scm_is_string(SCM_CAR(current)))
            compname = gnc_scm_to_utf8_string (SCM_CAR(current));
        else
            compname = g_strdup("");

        if (!scm_is_null(SCM_CADDR(current)))
        {
            leafnode = FALSE;
        }
        else
        {
            leafnode = TRUE;
        }

        /* compute full name */
        if (base_name && *base_name)
        {
            acctname = g_strjoin(gnc_get_account_separator_string(),
                                 base_name, compname, (char *)NULL);
        }
        else
        {
            acctname = g_strdup(compname);
        }

        checked = (SCM_CADR(current) == SCM_BOOL_T);

        gtk_tree_store_append(store, &iter, parent);
        gtk_tree_store_set(store, &iter,
                           ACCOUNT_COL_NAME, compname,
                           ACCOUNT_COL_FULLNAME, acctname,
                           ACCOUNT_COL_CHECK, checked,
                           -1);

        if (reference && !*reference &&
                search_name && (g_utf8_collate(search_name, acctname) == 0))
        {
            GtkTreePath *path = gtk_tree_model_get_path(GTK_TREE_MODEL(store), &iter);
            *reference = gtk_tree_row_reference_new(GTK_TREE_MODEL(store), path);
            gtk_tree_path_free(path);
        }

        if (!leafnode)
        {
            acct_tree_add_accts(SCM_CADDR(current), store, &iter, acctname,
                                search_name, reference);
        }

        g_free(acctname);
        g_free(compname);

        accts = SCM_CDR(accts);
    }
}