/* According to Section 5.2.1 of R5RS we first have to make sure that the
variable is bound, and then perform the `(set! variable expression)'
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
static SCM
expand_define (SCM expr, SCM env)
{
const SCM cdr_expr = CDR (expr);
SCM body;
SCM variable;
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
body = CDR (cdr_expr);
variable = CAR (cdr_expr);
if (scm_is_pair (variable))
{
ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
return TOPLEVEL_DEFINE
(scm_source_properties (expr),
CAR (variable),
expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
env));
}
ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
expand (CAR (body), env));
}
static SCM
lookup (SCM x, SCM env)
{
int d = 0;
for (; scm_is_pair (env); env = CDR (env), d++)
{
SCM link = CAR (env);
if (env_link_is_flat (link))
{
int w;
SCM vars;
for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
scm_is_pair (vars);
vars = CDR (vars), w--)
if (scm_is_eq (x, (CAAR (vars))))
return make_pos (d, w);
env_link_add_flat_var (link, x, lookup (x, CDR (env)));
return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
}
else
{
int w = try_lookup_rib (x, env_link_vars (link));
if (w < 0)
continue;
return make_pos (d, w);
}
}
abort ();
}
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
expand_set_x (SCM expr, SCM env)
{
SCM variable;
SCM vmem;
const SCM cdr_expr = CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
variable = CAR (cdr_expr);
vmem = expand (variable, env);
switch (SCM_EXPANDED_TYPE (vmem))
{
case SCM_EXPANDED_LEXICAL_REF:
return LEXICAL_SET (scm_source_properties (expr),
SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
expand (CADDR (expr), env));
case SCM_EXPANDED_TOPLEVEL_REF:
return TOPLEVEL_SET (scm_source_properties (expr),
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
expand (CADDR (expr), env));
case SCM_EXPANDED_MODULE_REF:
return MODULE_SET (scm_source_properties (expr),
SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
expand (CADDR (expr), env));
default:
syntax_error (s_bad_variable, variable, expr);
}
}
static SCM
expand_letstar (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
return expand_letstar_clause (CADR (expr), CDDR (expr), env);
}
static SCM
expand_atat (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr),
CADR (expr), CADDR (expr), SCM_BOOL_F);
}
static SCM
expand_quote (SCM expr, SCM env SCM_UNUSED)
{
SCM quotee;
const SCM cdr_expr = CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = CAR (cdr_expr);
return CONST (scm_source_properties (expr), quotee);
}
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_cond (SCM expr, SCM env)
{
const int else_literal_p = expand_env_var_is_free (env, scm_sym_else);
const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow);
const SCM clauses = CDR (expr);
ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
return expand_cond_clauses (CAR (clauses), CDR (clauses),
else_literal_p, arrow_literal_p, env);
}
static SCM
expand_begin (SCM expr, SCM env)
{
const SCM cdr_expr = CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
return expand_sequence (cdr_expr, env);
}
/*! \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;
}
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;
}
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
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;
}
/*! \brief read the configuration string list for the component dialog
* \par Function Description
* This function reads the string list from the component-dialog-attributes
* configuration parameter and converts the list into a GList.
* The GList is stored in the global default_component_select_attrlist variable.
*/
SCM g_rc_component_dialog_attributes(SCM stringlist)
{
int length, i;
GList *list=NULL;
gchar *attr;
SCM_ASSERT(scm_list_p(stringlist), stringlist, SCM_ARG1, "scm_is_list failed");
length = scm_ilength(stringlist);
/* If the command is called multiple times, remove the old list before
recreating it */
g_list_foreach(default_component_select_attrlist, (GFunc)g_free, NULL);
g_list_free(default_component_select_attrlist);
/* convert the scm list into a GList */
for (i=0; i < length; i++) {
SCM_ASSERT(scm_is_string(scm_list_ref(stringlist, scm_from_int(i))),
scm_list_ref(stringlist, scm_from_int(i)), SCM_ARG1,
"list element is not a string");
attr = g_strdup(SCM_STRING_CHARS(scm_list_ref(stringlist, scm_from_int(i))));
list = g_list_prepend(list, attr);
}
default_component_select_attrlist = g_list_reverse(list);
return SCM_BOOL_T;
}
/*=gfunc fprintf
*
* what: format to a file
* general_use:
*
* exparg: port, Guile-scheme output port
* exparg: format, formatting string
* exparg: format-arg, list of arguments to formatting string, opt, list
*
* doc: Format a string using arguments from the alist.
* Write to a specified port. The result will NOT appear in your
* output. Use this to print information messages to a template user.
=*/
SCM
ag_scm_fprintf(SCM port, SCM fmt, SCM alist)
{
int list_len = scm_ilength(alist);
char* pzFmt = ag_scm2zchars(fmt, zFormat);
SCM res = run_printf(pzFmt, list_len, alist);
return scm_display(res, port);
}
/*=gfunc printf
*
* what: format to stdout
* general_use:
*
* exparg: format, formatting string
* exparg: format-arg, list of arguments to formatting string, opt, list
*
* doc: Format a string using arguments from the alist.
* Write to the standard out port. The result will NOT appear in your
* output. Use this to print information messages to a template user.
* Use ``(sprintf ...)'' to add text to your document.
=*/
SCM
ag_scm_printf(SCM fmt, SCM alist)
{
int list_len = scm_ilength(alist);
char* pzFmt = ag_scm2zchars(fmt, zFormat);
AG_SCM_DISPLAY(run_printf(pzFmt, list_len, alist));
return SCM_UNDEFINED;
}
static LLVMTypeRef function_type(SCM scm_return_type, SCM scm_argument_types)
{
int n_arguments = scm_ilength(scm_argument_types);
LLVMTypeRef *parameters = scm_gc_malloc_pointerless(n_arguments * sizeof(LLVMTypeRef), "make-llvm-function");
for (int i=0; i<n_arguments; i++) {
parameters[i] = llvm_type(scm_to_int(scm_car(scm_argument_types)));
scm_argument_types = scm_cdr(scm_argument_types);
};
return LLVMFunctionType(llvm_type(scm_to_int(scm_return_type)), parameters, n_arguments, 0);
}
/*=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;
}
/*=gfunc sprintf
*
* what: format a string
* general_use:
*
* exparg: format, formatting string
* exparg: format-arg, list of arguments to formatting string, opt, list
*
* doc: Format a string using arguments from the alist.
=*/
SCM
ag_scm_sprintf(SCM fmt, SCM alist)
{
int list_len = scm_ilength(alist);
char* pzFmt = ag_scm2zchars(fmt, zFormat);
if (list_len <= 0)
return fmt;
return run_printf(pzFmt, list_len, alist);
}
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);
}
}
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));
}
/* 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);
}
}
SCM tf_add_input_list(SCM scm_description, SCM scm_inputs)
{
struct tf_description_t *self = get_tf_description(scm_description);
int num_inputs = scm_ilength(scm_inputs);
TF_Output *inputs = (TF_Output *)scm_gc_calloc(sizeof(struct TF_Output) * num_inputs, "tf-add-input-list");
for (int i=0; i<num_inputs; i++) {
inputs[i] = get_tf_output(scm_car(scm_inputs))->output;
scm_inputs = scm_cdr(scm_inputs);
};
TF_AddInputList(self->description, inputs, num_inputs);
return SCM_UNDEFINED;
}
static SCM
expand_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
return CONDITIONAL (scm_source_properties (expr),
expand (CADR (expr), env),
expand (CADDR (expr), env),
((length == 3)
? expand (CADDDR (expr), env)
: VOID (SCM_BOOL_F)));
}
SCM tf_set_attr_float_list(SCM scm_description, SCM scm_name, SCM scm_values)
{
struct tf_description_t *self = get_tf_description(scm_description);
int num_values = scm_ilength(scm_values);
float *values = scm_gc_malloc(sizeof(float) * num_values, "tf-set-attr-float-list");
for (int i=0; i<num_values; i++) {
values[i] = (float)scm_to_double(scm_car(scm_values));
scm_values = scm_cdr(scm_values);
};
char *name = scm_to_locale_string(scm_name);
TF_SetAttrFloatList(self->description, name, values, num_values);
free(name);
return SCM_UNDEFINED;
}
static SCM
expand_with_fluids (SCM expr, SCM env)
{
SCM binds, fluids, vals;
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
binds = CADR (expr);
ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
for (fluids = SCM_EOL, vals = SCM_EOL;
scm_is_pair (binds);
binds = CDR (binds))
{
SCM binding = CAR (binds);
ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
binding, expr);
fluids = scm_cons (expand (CAR (binding), env), fluids);
vals = scm_cons (expand (CADR (binding), env), vals);
}
return DYNLET (scm_source_properties (expr),
scm_reverse_x (fluids, SCM_UNDEFINED),
scm_reverse_x (vals, SCM_UNDEFINED),
expand_sequence (CDDR (expr), env));
}
SCM tf_set_attr_shape(SCM scm_description, SCM scm_name, SCM scm_shape)
{
struct tf_description_t *self = get_tf_description(scm_description);
int num_dims = scm_ilength(scm_shape);
int64_t *dims = scm_gc_malloc(sizeof(int64_t) * num_dims, "tf-set-attr-shape");
for (int i=0; i<num_dims; i++) {
dims[i] = scm_to_int(scm_car(scm_shape));
scm_shape = scm_cdr(scm_shape);
};
char *name = scm_to_locale_string(scm_name);
TF_SetAttrShape(self->description, name, dims, num_dims);
free(name);
return SCM_UNDEFINED;
}
/* 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);
}
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);
}
