/* * 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; }
static int pyscm_PySCM_setattr(pyscm_PySCMObject *self, char *name, PyObject *v) { /* Set attribute 'name' to value 'v'. v==NULL means delete */ if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) { scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_setattr: trying to set attribute=~S from pobj=~S to value ~S\n"),scm_list_3(scm_makfrom0str(name),verbosity_repr((PyObject *)self),verbosity_repr(v))); } SCM sobj_keyword; SCM sattr_vector = retrieve_sattr_vector(self,name,&sobj_keyword); if (SCM_UNBNDP(sattr_vector)) { // Attribute error exception was raised by retrieve_sattr_vector(). return(-1); } SCM ssetattr_func = GET_H_SETATTR_FUNC(sattr_vector); if (SCM_EQ_P(SCM_EOL,ssetattr_func)) { PyErr_SetString(PyExc_AttributeError, name); return(-1); } if (NULL != v) { SCM sval = p2g_apply(v, GET_H_P2G_SETATTR_TEMPLATE(sattr_vector)); scm_append_x(scm_list_2(sobj_keyword,sval)); } SCM sresult = scm_apply(ssetattr_func,sobj_keyword,SCM_EOL); return(SCM_EQ_P(SCM_BOOL_F,sresult) ? (-1) : 0); }
static SCM gfec_apply_helper(void *data) { struct gfec_apply_rec *apply_rec = (struct gfec_apply_rec *)data; return scm_apply(apply_rec->proc, apply_rec->arglist, SCM_EOL); }
G_MODULE_EXPORT void go_plugin_init (GOPlugin *p, GOCmdContext *cc) { char *name, *dir; *ret_error = NULL; scm_init_guile (); /* Initialize just in case. */ eval_pos = NULL; init_value_type (); scm_c_define_gsubr ("gnumeric-funcall", 2, 0, 0, scm_gnumeric_funcall); scm_c_define_gsubr ("register-function", 5, 0, 0, scm_register_function); dir = gnm_sys_data_dir ("guile"); name = g_strconcat (dir, "gnumeric_startup.scm", NULL); scm_apply (scm_c_eval_string ("(lambda (filename)" " (if (access? filename R_OK)" " (load filename)" " (display (string-append \"could not read Guile plug-in init file\" filename \"\n\"))))"), scm_cons (scm_makfrom0str (name), SCM_EOL), SCM_EOL); g_free (name); g_free (dir); /* Don't try to deactivate the plugin */ gnm_plugin_use_ref (PLUGIN); }
SWIGINTERN SCM SWIG_Guile_NewPointerObj(void *ptr, swig_type_info *type, int owner) { if (ptr == NULL) return SCM_EOL; else { SCM smob; swig_guile_clientdata *cdata = (swig_guile_clientdata *) type->clientdata; if (owner) SCM_NEWSMOB2(smob, swig_collectable_tag, ptr, (void *) type); else SCM_NEWSMOB2(smob, swig_tag, ptr, (void *) type); if (!cdata || SCM_NULLP(cdata->goops_class) || swig_make_func == SCM_EOL ) { return smob; } else { /* the scm_make() C function only handles the creation of gf, methods and classes (no instances) the (make ...) function is later redefined in goops.scm. So we need to call that Scheme function. */ return scm_apply(swig_make_func, scm_list_3(cdata->goops_class, swig_keyword, smob), SCM_EOL); } } }
/** * Convert version number strings into a binary representation and compare. */ SCM ag_scm_version_compare(SCM op, SCM v1, SCM v2) { static char const zVer[] = "version str"; ver_type_t val1 = str2int_ver(ag_scm2zchars(v1, zVer)); ver_type_t val2 = str2int_ver(ag_scm2zchars(v2, zVer)); v1 = SCM_FROM(val1); v2 = SCM_FROM(val2); return scm_apply(op, v1, scm_cons(v2, AG_SCM_LISTOFNULL())); }
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)); } }
static void test_query (Query *q, SCM val2str) { SCM scm_q; SCM str_q; SCM res_q; SCM args = SCM_EOL; Query *q2; gchar *str2 = NULL; scm_q = gnc_query2scm (q); args = scm_cons (scm_q, SCM_EOL); str_q = scm_apply (val2str, args, SCM_EOL); args = scm_cons (scm_from_utf8_string ("'"), scm_cons (str_q, SCM_EOL)); str_q = scm_string_append (args); str2 = gnc_scm_to_utf8_string (str_q); if (str2) { res_q = scm_c_eval_string (str2); } else { res_q = SCM_BOOL_F; } q2 = gnc_scm2query (res_q); if (!qof_query_equal (q, q2)) { failure ("queries don't match"); fprintf (stderr, "%s\n\n", str2 ? str2 : "(null)"); scm_q = gnc_query2scm (q2); scm_display (scm_q, SCM_UNDEFINED); scm_newline (SCM_UNDEFINED); g_free(str2); exit (1); } else { success ("queries match"); } g_free(str2); if (q2) qof_query_destroy (q2); }
static void test_query (Query *q, SCM val2str) { SCM scm_q; SCM str_q; SCM args = SCM_EOL; scm_q = gnc_query2scm (q); args = scm_cons (scm_q, SCM_EOL); str_q = scm_apply (val2str, args, SCM_EOL); args = scm_cons (scm_makfrom0str ("'"), scm_cons (str_q, SCM_EOL)); str_q = scm_string_append (args); scm_display (str_q, SCM_UNDEFINED); scm_newline (SCM_UNDEFINED); scm_newline (SCM_UNDEFINED); }
static PyObject * pyscm_PySCM_getattr(pyscm_PySCMObject *self, char *name) { if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) { scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_getattr: trying to get attribute=~S from pobj=~S\n"),scm_list_2(scm_makfrom0str(name),verbosity_repr((PyObject *)self))); } SCM sobj_keyword; SCM sattr_vector = retrieve_sattr_vector(self,name,&sobj_keyword); if (SCM_UNBNDP(sattr_vector)) { // Attribute error exception was raised by retrieve_sattr_vector(). return(NULL); } SCM sgetattr_func = GET_H_GETATTR_FUNC(sattr_vector); if (SCM_EQ_P(SCM_EOL,sgetattr_func)) { PyErr_SetString(PyExc_AttributeError, name); return(NULL); } SCM stemplate = GET_H_G2P_GETATTR_TEMPLATE(sattr_vector); SCM sresult = scm_apply(sgetattr_func,sobj_keyword,SCM_EOL); return(g2p_apply(sresult,stemplate)); }
static int build_owner_report (GncOwner *owner, Account *acc) { SCM args; SCM func; SCM arg; g_return_val_if_fail (owner, -1); args = SCM_EOL; func = scm_c_eval_string ("gnc:owner-report-create"); g_return_val_if_fail (scm_is_procedure (func), -1); if (acc) { swig_type_info * qtype = SWIG_TypeQuery("_p_Account"); g_return_val_if_fail (qtype, -1); arg = SWIG_NewPointerObj(acc, qtype, 0); g_return_val_if_fail (arg != SCM_UNDEFINED, -1); args = scm_cons (arg, args); } else { args = scm_cons (SCM_BOOL_F, args); } arg = SWIG_NewPointerObj(owner, SWIG_TypeQuery("_p__gncOwner"), 0); g_return_val_if_fail (arg != SCM_UNDEFINED, -1); args = scm_cons (arg, args); /* Apply the function to the args */ arg = scm_apply (func, args, SCM_EOL); g_return_val_if_fail (scm_is_exact (arg), -1); return scm_to_int (arg); }
static int build_aging_report (GncOwnerType owner_type) { gchar *report_name = NULL; gchar *report_title = NULL; SCM args; SCM func; SCM arg; args = SCM_EOL; switch (owner_type) { case GNC_OWNER_NONE : case GNC_OWNER_UNDEFINED : case GNC_OWNER_EMPLOYEE : case GNC_OWNER_JOB : { return -1; } case GNC_OWNER_VENDOR : { report_name = "gnc:payables-report-create"; report_title = _("Vendor Listing"); break; } case GNC_OWNER_CUSTOMER : { report_name = "gnc:receivables-report-create"; report_title = _("Customer Listing"); break; } } /* Find report generator function in guile */ func = scm_c_eval_string (report_name); g_return_val_if_fail (scm_is_procedure (func), -1); /* Option Show zero's ? - Yes for the listing report */ arg = SCM_BOOL_T; args = scm_cons (arg, args); g_return_val_if_fail (arg != SCM_UNDEFINED, -1); /* Option Report title */ arg = scm_from_locale_string (report_title); args = scm_cons (arg, args); /* Option Account - Using False to select default account * * XXX I'm not sure if it would make sense to use another * account than default */ arg = SCM_BOOL_F; args = scm_cons (arg, args); g_return_val_if_fail (arg != SCM_UNDEFINED, -1); /* Apply the function to the args */ arg = scm_apply (func, args, SCM_EOL); g_return_val_if_fail (scm_is_exact (arg), -1); return scm_to_int (arg); }
/********************************************************************\ * gnc_copy_trans_scm_onto_trans_swap_accounts * * copies a scheme representation of a transaction onto * * an actual transaction. If guid_1 and guid_2 are not NULL, * * the account guids of the splits are swapped accordingly. * * * * Args: trans_scm - the scheme representation of a transaction * * trans - the transaction to copy onto * * guid_1 - account guid to swap with guid_2 * * guid_2 - account guid to swap with guid_1 * * do_commit - whether to commit the edits * * Returns: Nothing * \********************************************************************/ void gnc_copy_trans_scm_onto_trans_swap_accounts(SCM trans_scm, Transaction *trans, const GncGUID *guid_1, const GncGUID *guid_2, gboolean do_commit, QofBook *book) { static swig_type_info *trans_type = NULL; SCM result; SCM func; SCM arg; if (trans_scm == SCM_UNDEFINED) return; if (trans == NULL) return; g_return_if_fail (book); func = scm_c_eval_string("gnc:transaction-scm?"); if (!scm_is_procedure(func)) return; result = scm_call_1(func, trans_scm); if (!scm_is_true(result)) return; func = scm_c_eval_string("gnc:transaction-scm-onto-transaction"); if (!scm_is_procedure(func)) return; if (!trans_type) trans_type = SWIG_TypeQuery("_p_Transaction"); arg = SWIG_NewPointerObj(trans, trans_type, 0); if ((guid_1 == NULL) || (guid_2 == NULL)) { SCM args = SCM_EOL; SCM commit; commit = SCM_BOOL(do_commit); args = scm_cons(gnc_book_to_scm (book), args); args = scm_cons(commit, args); args = scm_cons(SCM_EOL, args); args = scm_cons(arg, args); args = scm_cons(trans_scm, args); scm_apply(func, args, SCM_EOL); } else { gchar guidstr[GUID_ENCODING_LENGTH+1]; SCM from, to; SCM map = SCM_EOL; SCM args = SCM_EOL; SCM commit; args = scm_cons(gnc_book_to_scm (book), args); commit = SCM_BOOL(do_commit); args = scm_cons(commit, args); guid_to_string_buff(guid_1, guidstr); from = scm_from_utf8_string(guidstr); guid_to_string_buff(guid_2, guidstr); to = scm_from_utf8_string(guidstr); map = scm_cons(scm_cons(from, to), map); map = scm_cons(scm_cons(to, from), map); args = scm_cons(map, args); args = scm_cons(arg, args); args = scm_cons(trans_scm, args); scm_apply(func, args, SCM_EOL); } }
/* FIXME: needs comment: */ void scm_scmval_print(LONGEST svalue, struct ui_file *stream, int format, int deref_ref, int recurse, enum val_prettyprint pretty) { taloop: switch (7 & (int)svalue) { case 2: case 6: print_longest(stream, (format ? format : 'd'), 1, (svalue >> 2)); break; case 4: if (SCM_ICHRP(svalue)) { svalue = SCM_ICHR(svalue); scm_printchar((int)svalue, stream); break; } else if (SCM_IFLAGP(svalue) && ((size_t)SCM_ISYMNUM(svalue) < (sizeof(scm_isymnames) / sizeof(char *)))) { fputs_filtered(SCM_ISYMCHARS(svalue), stream); break; } else if (SCM_ILOCP(svalue)) { fprintf_filtered(stream, "#@%ld%c%ld", (long)SCM_IFRAME(svalue), (SCM_ICDRP(svalue) ? '-' : '+'), (long)SCM_IDIST(svalue)); break; } else goto idef; break; case 1: /* gloc */ svalue = SCM_CAR (svalue - 1); goto taloop; default: idef: scm_ipruk ("immediate", svalue, stream); break; case 0: switch (SCM_TYP7 (svalue)) { case scm_tcs_cons_gloc: if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0) { #if 0 SCM name; #endif /* 0 */ fputs_filtered ("#<latte ", stream); #if 1 fputs_filtered ("???", stream); #else name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name]; scm_lfwrite (CHARS (name), (sizet) sizeof (char), (sizet) LENGTH (name), port); #endif /* 1 */ fprintf_filtered (stream, " #X%s>", paddr_nz (svalue)); break; } /* -Wimplicit-fallthrough vs. -Wdeclaration-after-statement: */ goto imcar_noncase_label; imcar_noncase_label: case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: fputs_filtered ("(", stream); scm_scmlist_print (svalue, stream, format, deref_ref, recurse + 1, pretty); fputs_filtered (")", stream); break; case scm_tcs_closures: fputs_filtered ("#<CLOSURE ", stream); scm_scmlist_print (SCM_CODE (svalue), stream, format, deref_ref, recurse + 1, pretty); fputs_filtered (">", stream); break; case scm_tc7_string: { size_t len = SCM_LENGTH(svalue); CORE_ADDR addr = (CORE_ADDR)SCM_CDR(svalue); size_t i; size_t done = 0UL; size_t buf_size; gdb_byte buffer[64]; int truncate = (print_max && (len > print_max)); if (truncate) len = print_max; fputs_filtered ("\"", stream); for (; done < len; done += buf_size) { buf_size = min((len - done), 64); read_memory((addr + done), buffer, (int)buf_size); for (i = 0; i < buf_size; ++i) switch (buffer[i]) { case '\"': case '\\': fputs_filtered("\\", stream); goto the_default_label; the_default_label: default: fprintf_filtered(stream, "%c", buffer[i]); } } fputs_filtered((truncate ? "...\"" : "\""), stream); break; } break; case scm_tcs_symbols: { const size_t len = min(SCM_LENGTH(svalue), MAX_ALLOCA_SIZE); char *str = (char *)alloca(min(len, MAX_ALLOCA_SIZE)); read_memory(SCM_CDR(svalue), (gdb_byte *)str, (int)(len + 1)); /* Should handle weird characters, FIXME: do it. */ str[len] = '\0'; fputs_filtered(str, stream); break; } case scm_tc7_vector: { long len = SCM_LENGTH(svalue); int i; LONGEST elements = SCM_CDR(svalue); fputs_filtered ("#(", stream); for (i = 0; i < len; ++i) { if (i > 0) fputs_filtered (" ", stream); scm_scmval_print (scm_get_field (elements, i), stream, format, deref_ref, recurse + 1, pretty); } fputs_filtered (")", stream); } break; #if 0 case tc7_lvector: { SCM result; SCM hook; hook = scm_get_lvector_hook (exp, LV_PRINT_FN); if (hook == BOOL_F) { scm_puts ("#<locked-vector ", port); scm_intprint (CDR (exp), 16, port); scm_puts (">", port); } else { result = scm_apply (hook, scm_listify (exp, port, (writing ? BOOL_T : BOOL_F), SCM_UNDEFINED), EOL); if (result == BOOL_F) goto punk; } break; } break; case tc7_bvect: case tc7_ivect: case tc7_uvect: case tc7_fvect: case tc7_dvect: case tc7_cvect: scm_raprin1 (exp, port, writing); break; #endif /* 0 */ case scm_tcs_subrs: { int index = (int)(SCM_CAR(svalue) >> 8); #if 1 char str[20]; snprintf(str, sizeof(str), "#%d", index); #else char *str = (index ? SCM_CHARS(scm_heap_org + index) : ""); # define SCM_CHARS(x) ((char *)(SCM_CDR(x))) char *str = CHARS(SNAME(exp)); #endif /* 1 */ fprintf_filtered(stream, "#<primitive-procedure %s>", str); } break; #if 0 #ifdef CCLO case tc7_cclo: scm_puts ("#<compiled-closure ", port); scm_iprin1 (CCLO_SUBR (exp), port, writing); scm_putc ('>', port); break; #endif case tc7_contin: fprintf_filtered (stream, "#<continuation %d @ #X%lx >", LENGTH (svalue), (long) CHARS (svalue)); break; case tc7_port: i = PTOBNUM (exp); if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing)) break; goto punk; case tc7_smob: i = SMOBNUM (exp); if (i < scm_numsmob && scm_smobs[i].print && (scm_smobs[i].print) (exp, port, writing)) break; goto punk; #endif default: #if 0 punk: #endif scm_ipruk ("type", svalue, stream); } break; } }
SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args) { return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)), SCM_EOL); }
SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args) { return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL); }
SCM scm_apply_1 (SCM proc, SCM arg1, SCM args) { return scm_apply (proc, scm_cons (arg1, args), SCM_EOL); }
SCM scm_apply_0 (SCM proc, SCM args) { return scm_apply (proc, args, SCM_EOL); }