static SCM
ppscm_search_pp_list (SCM list, SCM value)
{
SCM orig_list = list;
if (scm_is_null (list))
return SCM_BOOL_F;
if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), list);
}
for ( ; scm_is_pair (list); list = scm_cdr (list))
{
SCM matcher = scm_car (list);
SCM worker;
pretty_printer_smob *pp_smob;
if (!ppscm_is_pretty_printer (matcher))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list contains non-pretty-printer object"),
matcher);
}
pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
/* Skip if disabled. */
if (gdbscm_is_false (pp_smob->enabled))
continue;
if (!gdbscm_is_procedure (pp_smob->lookup))
{
return ppscm_make_pp_type_error_exception
(_("invalid lookup object in pretty-printer matcher"),
pp_smob->lookup);
}
worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
value, gdbscm_memory_error_p);
if (!gdbscm_is_false (worker))
{
if (gdbscm_is_exception (worker))
return worker;
if (ppscm_is_pretty_printer_worker (worker))
return worker;
return ppscm_make_pp_type_error_exception
(_("invalid result from pretty-printer lookup"), worker);
}
}
if (!scm_is_null (list))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), orig_list);
}
return SCM_BOOL_F;
}
SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
{
if (!SCM_UNBNDP (filename))
{
SCM old_alist = alist;
/*
have to extract the acons, and operate on that, for
thread safety.
*/
SCM last_acons = SCM_CDR (scm_last_alist_filename);
if (scm_is_null (old_alist)
&& scm_is_eq (SCM_CDAR (last_acons), filename))
{
alist = last_acons;
}
else
{
alist = scm_acons (scm_sym_filename, filename, alist);
if (scm_is_null (old_alist))
scm_set_cdr_x (scm_last_alist_filename, alist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
SCM_UNPACK (copy),
SCM_UNPACK (alist));
}
static SCM
expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
{
SCM test;
const long length = scm_ilength (clause);
ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);
test = CAR (clause);
if (scm_is_eq (test, scm_sym_else) && elp)
{
const int last_clause_p = scm_is_null (rest);
ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
return expand_sequence (CDR (clause), env);
}
if (scm_is_null (rest))
rest = VOID (SCM_BOOL_F);
else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
if (length >= 2
&& scm_is_eq (CADR (clause), scm_sym_arrow)
&& alp)
{
SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
SCM new_env = scm_acons (tmp, tmp, env);
ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
return LET (SCM_BOOL_F,
scm_list_1 (tmp),
scm_list_1 (tmp),
scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
CALL (SCM_BOOL_F,
expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
tmp, tmp))),
rest));
}
/* FIXME length == 1 case */
else
return CONDITIONAL (SCM_BOOL_F,
expand (test, env),
expand_sequence (CDR (clause), env),
rest);
}
static SCM
expand_let (SCM expr, SCM env)
{
SCM bindings;
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
bindings = CAR (cdr_expr);
if (scm_is_symbol (bindings))
{
ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
return expand_named_let (expr, env);
}
check_bindings (bindings, expr);
if (scm_is_null (bindings))
return expand_sequence (CDDR (expr), env);
else
{
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
return LET (SCM_BOOL_F,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr),
expand_env_extend (env, var_names,
var_syms)));
}
}
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;
}
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);
}
static SCM
expand_and (SCM expr, SCM env)
{
const SCM cdr_expr = CDR (expr);
if (scm_is_null (cdr_expr))
return CONST (SCM_BOOL_F, SCM_BOOL_T);
ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
if (scm_is_null (CDR (cdr_expr)))
return expand (CAR (cdr_expr), env);
else
return CONDITIONAL (scm_source_properties (expr),
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env),
CONST (SCM_BOOL_F, SCM_BOOL_F));
}
static SCM
expand_exprs (SCM forms, const SCM env)
{
SCM ret = SCM_EOL;
for (; !scm_is_null (forms); forms = CDR (forms))
ret = scm_cons (expand (CAR (forms), env), ret);
return scm_reverse_x (ret, SCM_UNDEFINED);
}
/********************************************************************
* 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);
}
}
}
static SCM
expand_sequence (const SCM forms, const SCM env)
{
ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
scm_cons (scm_sym_begin, forms));
if (scm_is_null (CDR (forms)))
return expand (CAR (forms), env);
else
return SEQ (scm_source_properties (forms),
expand (CAR (forms), env),
expand_sequence (CDR (forms), env));
}
/*! \brief Re-poll a scheme procedure for symbols.
* \par Function Description
* Calls a Scheme procedure to obtain a list of available symbols,
* and updates the source with the new list
*
* Private function used only in s_clib.c.
*/
static void refresh_scm (CLibSource *source)
{
SCM symlist;
SCM symname;
CLibSymbol *symbol;
char *tmp;
g_return_if_fail (source != NULL);
g_return_if_fail (source->type == CLIB_SCM);
/* Clear the current symbol list */
g_list_foreach (source->symbols, (GFunc) free_symbol, NULL);
g_list_free (source->symbols);
source->symbols = NULL;
symlist = scm_call_0 (source->list_fn);
if (scm_is_false (scm_list_p (symlist))) {
s_log_message (_("Failed to scan library [%1$s]: Scheme function returned non-list."),
source->name);
return;
}
while (!scm_is_null (symlist)) {
symname = SCM_CAR (symlist);
if (!scm_is_string (symname)) {
s_log_message (_("Non-string symbol name while scanning library [%1$s]"),
source->name);
} else {
symbol = g_new0 (CLibSymbol, 1);
symbol->source = source;
/* Need to make sure that the correct free() function is called
* on strings allocated by Guile. */
tmp = scm_to_utf8_string (symname);
symbol->name = g_strdup(tmp);
free (tmp);
/* Prepend because it's faster and it doesn't matter what order we
* add them. */
source->symbols = g_list_prepend (source->symbols, symbol);
}
symlist = SCM_CDR (symlist);
}
/* Now sort the list of symbols by name. */
source->symbols = g_list_sort (source->symbols,
(GCompareFunc) compare_symbol_name);
s_clib_flush_search_cache();
s_clib_flush_symbol_cache();
}
static void
gnc_style_sheet_select_dialog_fill(StyleSheetDialog * ss)
{
SCM stylesheets = scm_c_eval_string("(gnc:get-html-style-sheets)");
SCM sheet_info;
/* pack it full of content */
for (; !scm_is_null(stylesheets); stylesheets = SCM_CDR(stylesheets))
{
sheet_info = SCM_CAR(stylesheets);
gnc_style_sheet_select_dialog_add_one(ss, sheet_info, FALSE);
}
}
static int
more_specificp (SCM m1, SCM m2, SCM const *targs)
{
register SCM s1, s2;
register long i;
/*
* Note:
* m1 and m2 can have != length (i.e. one can be one element longer than the
* other when we have a dotted parameter list). For instance, with the call
* (M 1)
* with
* (define-method M (a . l) ....)
* (define-method M (a) ....)
*
* we consider that the second method is more specific.
*
* BTW, targs is an array of types. We don't need it's size since
* we already know that m1 and m2 are applicable (no risk to go past
* the end of this array).
*
*/
for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
if (scm_is_null(s1)) return 1;
if (scm_is_null(s2)) return 0;
if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) {
if (scm_is_eq (cs1, SCM_CAR (l)))
return 1;
if (scm_is_eq (cs2, SCM_CAR (l)))
return 0;
}
return 0;/* should not occur! */
}
}
return 0; /* should not occur! */
}
int scm_list_to_imht_set(SCM scm_a, imht_set_t **result) {
int a_length = scm_to_uint32((scm_length(scm_a)));
if (!imht_set_create((3 + a_length), result)) {
return (1);
};
while (!scm_is_null(scm_a)) {
if (!imht_set_add((*result), (scm_to_int((SCM_CAR(scm_a)))))) {
imht_set_destroy((*result));
return (2);
};
scm_a = SCM_CDR(scm_a);
};
return (0);
};
int scm_is_alist(SCM x) {
SCM item;
if (!scm_is_list(x))
return 0;
while (!scm_is_null(x)) {
item = SCM_CAR(x);
if (!scm_is_pair(item))
return 0;
x = SCM_CDR(x);
}
return 1;
}
/**************************************************************
* custom_report_run_report
*
* this procedure sets up and calls the report on the scheme
* side. This is what makes the report actually run.
**************************************************************/
static void
custom_report_edit_report_name (SCM guid,
CustomReportDialog *crd,
gchar *new_name)
{
SCM rename_report = scm_c_eval_string("gnc:rename-report");
SCM new_name_scm = scm_from_utf8_string(new_name);
if (scm_is_null(guid) || !new_name || (*new_name == '\0'))
return;
/* rename the report */
scm_call_2(rename_report, guid, new_name_scm);
update_report_list(GTK_LIST_STORE(gtk_tree_view_get_model(GTK_TREE_VIEW(crd->reportview))),
crd);
}
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);
}
void
custom_report_name_edited_cb(GtkCellRendererText *renderer, gchar *path, gchar *new_text, gpointer data)
{
CustomReportDialog *crd = data;
SCM guid = get_custom_report_selection(crd, _("Unable to change report configuration name."));
SCM unique_name_func = scm_c_eval_string("gnc:report-template-has-unique-name?");
SCM new_name_scm = scm_from_utf8_string(new_text);
g_object_set(G_OBJECT(crd->namerenderer), "editable", FALSE, NULL);
if (scm_is_null (guid))
return;
if (scm_is_true (scm_call_2 (unique_name_func, guid, new_name_scm)))
custom_report_edit_report_name (guid, crd, new_text);
else
gnc_error_dialog (GTK_WINDOW (crd->dialog), "%s",
_("A saved report configuration with this name already exists, please choose another name.") );
}
static SCM pg_map_rows(SCM res, SCM rest) {
struct pg_res *pgr;
SCM bag, row;
scm_assert_smob_type(pg_res_tag, res);
bag = row = SCM_EOL;
pgr = (struct pg_res *)SCM_SMOB_DATA(res);
while (pgr->cursor < pgr->tuples) {
row = build_row(pgr);
if (!scm_is_null(rest))
bag = scm_cons(scm_call_1(SCM_CAR(rest), row), bag);
else bag = scm_cons(row, bag);
pgr->cursor++;
}
PQclear(pgr->res);
pgr->res = NULL;
bag = scm_reverse(bag);
scm_remember_upto_here_2(bag, row);
scm_remember_upto_here_2(res, rest);
return bag;
}
/*********************************************************************
* custom_report_delete
*
* this will delete the report, update the reports list and leave the
* dialog active for additional usage.
*********************************************************************/
static void
custom_report_delete (SCM guid, CustomReportDialog *crd)
{
SCM template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
gchar *report_name;
if (scm_is_null (guid))
return;
report_name = gnc_scm_to_utf8_string(scm_call_2(template_menu_name, guid, SCM_BOOL_F));
/* we must confirm the user wants to delete their precious custom report! */
if (gnc_verify_dialog( GTK_WINDOW (crd->dialog), FALSE, _("Are you sure you want to delete %s?"), report_name))
{
SCM del_report = scm_c_eval_string("gnc:delete-report");
scm_call_1(del_report, guid);
update_report_list(GTK_LIST_STORE(gtk_tree_view_get_model(GTK_TREE_VIEW(crd->reportview))),
crd);
}
g_free (report_name);
}
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
static void
check_bindings (const SCM bindings, const SCM expr)
{
SCM binding_idx;
ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
s_bad_bindings, bindings, expr);
binding_idx = bindings;
for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
{
SCM name; /* const */
const SCM binding = CAR (binding_idx);
ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
s_bad_binding, binding, expr);
name = CAR (binding);
ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
}
}
GSList *
gnc_scm_to_gslist_string(SCM list)
{
GSList *gslist = NULL;
while (!scm_is_null (list))
{
if (scm_is_string(SCM_CAR(list)))
{
gchar * str;
str = gnc_scm_to_locale_string (SCM_CAR(list));
if (str)
gslist = g_slist_prepend (gslist, g_strdup (str));
g_free (str);
}
list = SCM_CDR (list);
}
return g_slist_reverse (gslist);
}
SCM
scm_find_method (SCM l)
#define FUNC_NAME "find-method"
{
SCM gf;
long len = scm_ilength (l);
if (len == 0)
SCM_WRONG_NUM_ARGS ();
scm_c_issue_deprecation_warning
("scm_find_method is deprecated. Use `compute-applicable-methods' "
"from Scheme instead.");
gf = SCM_CAR(l); l = SCM_CDR(l);
SCM_VALIDATE_GENERIC (1, gf);
if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
return scm_compute_applicable_methods (gf, l, len - 1, 1);
}
/**************************************************************
* custom_report_run_report
*
* this procedure sets up and calls the report on the scheme
* side. This is what makes the report actually run.
**************************************************************/
static void
custom_report_run_report(SCM guid,
CustomReportDialog *crd)
{
SCM make_report = scm_c_eval_string("gnc:make-report");
int report_id;
GncMainWindow *window = crd->window;
if (scm_is_null(guid))
return;
/* this generates the report */
report_id = scm_to_int (scm_call_1(make_report, guid));
/* do this *before* displaying the report because sometimes that
takes a while... */
custom_report_dialog_close_cb(NULL, crd);
/* display the report */
gnc_main_window_open_report(report_id, window);
}
/*
* Recursive routine. It calls itself for list values and calls
* "do_substitution" for string values. Each substitution will
* be done in the order found in the tree walk of list values.
* The "match" and "repl" trees *must* be identical in structure.
*/
LOCAL void
do_multi_subs(char ** ppzStr, ssize_t * pStrLen, SCM match, SCM repl)
{
char * pzStr = *ppzStr;
char * pzNxt = pzStr;
/*
* Loop for as long as our list has more entries
*/
while (! scm_is_null(match)) {
/*
* "CAR" is the current value, "CDR" is rest of list
*/
SCM matchCar = SCM_CAR(match);
SCM replCar = SCM_CAR(repl);
match = SCM_CDR(match);
repl = SCM_CDR(repl);
if (AG_SCM_STRING_P(matchCar)) {
do_substitution(pzStr, *pStrLen, matchCar, replCar,
&pzNxt, pStrLen);
// coverity[use_after_free] -- invalid alias analysis
pzStr = pzNxt;
}
else if (AG_SCM_LIST_P(matchCar))
do_multi_subs(&pzStr, pStrLen, matchCar, replCar);
else
/*
* Whatever it is it is not part of what we would expect. Bail.
*/
break;
}
*ppzStr = pzStr;
}
static SCM
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
{
if (scm_is_null (bindings))
return expand_sequence (body, env);
else
{
SCM bind, name, sym, init;
ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
bind = CAR (bindings);
ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
name = CAR (bind);
sym = scm_gensym (SCM_UNDEFINED);
init = CADR (bind);
return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
scm_list_1 (expand (init, env)),
expand_letstar_clause (CDR (bindings), body,
scm_acons (name, sym, env)));
}
}
static SCM touch_node(SCM doc, SCM args) {
MAKE_NODE *node;
node = (MAKE_NODE *)SCM_SMOB_DATA(doc);
scm_lock_mutex(node->mutex);
invalidate(node);
if (scm_is_null(args)) {
scm_unlock_mutex(node->mutex);
return SCM_BOOL_T;
}
switch (node->type) {
case TYPE_DATUM:
node->payload = SCM_CAR(args);
break;
case TYPE_FILE:
free(node->filepath);
node->filepath = scm_to_locale_string(SCM_CAR(args));
break;
}
scm_unlock_mutex(node->mutex);
scm_remember_upto_here_2(doc, args);
return SCM_BOOL_T;
}
static SCM pg_format_sql(SCM conn, SCM obj) {
struct pg_conn *pgc;
SCM out;
if (SCM_SMOB_PREDICATE(time_tag, obj)) {
out = format_time(obj, c2s("'%Y-%m-%d %H:%M:%S'"));
}
else if (scm_boolean_p(obj) == SCM_BOOL_T) {
if (scm_is_true(obj)) out = c2s("'t'");
else out = c2s("'f'");
}
else if (scm_is_number(obj)) {
out = scm_number_to_string(obj,
scm_from_signed_integer(10));
}
else if (scm_is_symbol(obj)) {
out = pg_format_sql(conn, scm_symbol_to_string(obj));
}
else if (scm_is_string(obj)) {
if (scm_string_null_p(obj) == SCM_BOOL_T) out = c2s("NULL");
else {
char *src = scm_to_utf8_string(obj);
scm_assert_smob_type(pg_conn_tag, conn);
pgc = (struct pg_conn *)SCM_SMOB_DATA(conn);
scm_lock_mutex(pgc->mutex);
char *sql = PQescapeLiteral(pgc->conn,
src, strlen(src));
out = safe_from_utf8(sql);
scm_unlock_mutex(pgc->mutex);
free(src);
PQfreemem(sql);
}
}
else if (scm_is_null(obj)) out = c2s("NULL");
else out = c2s("NULL");
scm_remember_upto_here_1(out);
scm_remember_upto_here_2(conn, obj);
return out;
}
static SCM
expand_or (SCM expr, SCM env SCM_UNUSED)
{
SCM tail = CDR (expr);
const long length = scm_ilength (tail);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr)))
return CONST (SCM_BOOL_F, SCM_BOOL_F);
else
{
SCM tmp = scm_gensym (SCM_UNDEFINED);
return LET (SCM_BOOL_F,
scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (expand (CADR (expr), env)),
CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
expand_or (CDR (expr),
scm_acons (tmp, tmp, env))));
}
}
/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
* transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
* variable name is detected, an error is signalled. */
static void
transform_bindings (const SCM bindings, const SCM expr,
SCM *const names, SCM *const vars, SCM *const initptr)
{
SCM rnames = SCM_EOL;
SCM rvars = SCM_EOL;
SCM rinits = SCM_EOL;
SCM binding_idx = bindings;
for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
{
const SCM binding = CAR (binding_idx);
const SCM CDR_binding = CDR (binding);
const SCM name = CAR (binding);
ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
s_duplicate_binding, name, expr);
rnames = scm_cons (name, rnames);
rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
rinits = scm_cons (CAR (CDR_binding), rinits);
}
*names = scm_reverse_x (rnames, SCM_UNDEFINED);
*vars = scm_reverse_x (rvars, SCM_UNDEFINED);
*initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
}
