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 Expr* list(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return EMPTY_LIST;
Expr* head = scm_mk_pair(EMPTY_LIST, EMPTY_LIST);
Expr* cur = head;
if(!head) return OOM;
scm_stack_push(&head);
while(scm_is_pair(args) && scm_is_pair(scm_cdr(args))) {
cur->pair.car = scm_car(args);
Expr* next = scm_mk_pair(EMPTY_LIST, EMPTY_LIST);
if(!next) {
cur = NULL;
break;
}
cur->pair.cdr = next;
cur = next;
args = scm_cdr(args);
}
scm_stack_pop(&head);
if(!cur) return OOM;
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("Args to list aren't in a proper list");
cur->pair.car = scm_car(args);
return head;
}
static Expr* num_lte(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return TRUE;
Expr* cur = scm_car(args);
checknum(cur);
bool ok = true;
double curVal = scm_is_int(cur) ? scm_ival(cur) : scm_rval(cur);
args = scm_cdr(args);
while(scm_is_pair(args)) {
cur = scm_car(args);
checknum(cur);
double newVal = scm_is_int(cur) ? scm_ival(cur) : scm_rval(cur);
if(newVal < curVal) {
ok = false;
break;
}
curVal = newVal;
args = scm_cdr(args);
}
if(ok && args != EMPTY_LIST) return scm_mk_error("arguments to <= aren't a proper list");
return ok ? TRUE : FALSE;
}
static Expr* num_eq(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return TRUE;
Expr* cur = scm_car(args);
checknum(cur);
bool eq = true;
bool exact = scm_is_int(cur);
long long ex;
double in;
if(exact) {
ex = scm_ival(cur);
in = ex;
} else {
in = scm_rval(cur);
ex = in;
exact = ((double)ex) == in;
}
args = scm_cdr(args);
while(scm_is_pair(args)) {
cur = scm_car(args);
checknum(cur);
if(exact && scm_is_int(cur)) {
if(ex != scm_ival(cur)) {
eq = false;
break;
}
} else if(exact) {
if(in != scm_rval(cur)) {
eq = false;
break;
}
} else if(scm_is_real(cur)) {
if(in != scm_rval(cur)) {
eq = false;
break;
}
} else {
eq = false;
break;
}
args = scm_cdr(args);
}
if(eq && args != EMPTY_LIST) return scm_mk_error("arguments to = aren't a proper list");
return eq ? TRUE : FALSE;
}
static Expr* cdr(Expr* args) {
assert(args);
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("passed more than 1 arg to cdr");
Expr* arg = scm_car(args);
if(!scm_is_pair(arg)) return scm_mk_error("arg to cdr must be a pair");
return scm_cdr(arg);
}
static void conv_highlight_keywords(struct conv *conv)
{
int key_index = 0;
scheme *sc = conv->proc->sc;
pointer sym = conv->proc->code;
assert(sc);
assert(sym);
if (sym == sc->NIL) {
warn("%s: conv proc not a symbol", __FUNCTION__);
return;
}
pointer ifc = sc->vptr->find_slot_in_env(sc, sc->envir, sym, 1);
if (! scm_is_pair(sc, ifc)) {
warn("%s: conv '%s' has no value", __FUNCTION__, scm_sym_val(sc, sym));
return;
}
pointer clos = scm_cdr(sc, ifc);
if (! scm_is_closure(sc, clos)) {
warn("%s: conv '%s' not a closure", __FUNCTION__, scm_sym_val(sc, sym));
return;
}
pointer env = scm_cdr(sc, clos);
pointer vtable = scm_cdr(sc, scm_car(sc, scm_car(sc, env)));
conv->n_keywords = scm_len(sc, vtable);
if (!(conv->keywords = (char**)calloc(conv->n_keywords, sizeof(char*)))) {
warn("%s: failed to allocate keyword array size %d", __FUNCTION__, conv->n_keywords);
return;
}
if (!(conv->marked = bitset_alloc(conv->n_keywords))) {
warn("%s: failed to allocate bitset array size %d", __FUNCTION__, conv->n_keywords);
return;
}
while (scm_is_pair(sc, vtable)) {
pointer binding = scm_car(sc, vtable);
vtable = scm_cdr(sc, vtable);
pointer var = scm_car(sc, binding);
if (conv_add_keyword(conv, scm_sym_val(sc, var), key_index)) {
return;
}
key_index++;
}
conv_sort_keywords(conv);
}
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;
}
/*! \brief Get the action position.
* \par Function Description
* Retrieves the current action position and stores it in \a x and \a
* y, optionally snapping it to the grid if \a snap is true. This
* should be interpreted as the position that the user was pointing
* with the mouse pointer when the current action was invoked. If
* there is no valid world position for the current action, returns
* FALSE without modifying the output variables.
*
* This should be used by actions implemented in C to figure out where
* on the schematic the user wants them to apply the action.
*
* See also the (gschem action) Scheme module.
*
* \param w_current Current gschem toplevel structure.
* \param x Location to store x coordinate.
* \param y Location to store y coordinate.
*
* \return TRUE if current action position is set, FALSE otherwise.
*/
gboolean
g_action_get_position (gboolean snap, int *x, int *y)
{
SCM s_action_position_proc;
SCM s_point;
GschemToplevel *w_current = g_current_window ();
g_assert (w_current);
/* Get the action-position procedure */
s_action_position_proc =
scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("gschem action"),
"action-position"));
/* Retrieve the action position */
s_point = scm_call_0 (s_action_position_proc);
if (scm_is_false (s_point)) return FALSE;
if (x) {
*x = scm_to_int (scm_car (s_point));
if (snap) {
*x = snap_grid (w_current, *x);
}
}
if (y) {
*y = scm_to_int (scm_cdr (s_point));
if (snap) {
*y = snap_grid (w_current, *y);
}
}
return TRUE;
}
static Expr* mul(Expr* args) {
assert(args);
double dbuf = 1.0;
long long lbuf = 1;
bool exact = true;
while(scm_is_pair(args)) {
Expr* cur = scm_car(args);
if(scm_is_int(cur)) {
lbuf *= scm_ival(cur);
dbuf *= scm_ival(cur);
} else if(scm_is_real(cur)) {
exact = false;
dbuf *= scm_rval(cur);
} else {
return scm_mk_error("Wrong type of argument to *");
}
args = scm_cdr(args);
}
if(args != EMPTY_LIST) {
return scm_mk_error("args to * aren't a proper list");
}
return exact ? scm_mk_int(lbuf) : scm_mk_real(dbuf);
}
static Expr* pair(Expr* args) {
assert(args);
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("passed more than 1 arg to pair?");
return scm_is_pair(scm_car(args)) ? TRUE : FALSE;
}
SCM
guile_comm_init (SCM args) // MPI_Init
{
int argc, i;
char **argv;
// count number of arguments:
argc = scm_to_int (scm_length (args));
argv = malloc ((argc + 1) * sizeof (char *));
argv[argc] = NULL;
for (i = 0; i < argc; i++)
{
argv[i] = scm_to_locale_string (scm_car (args));
args = scm_cdr (args);
}
int ierr = MPI_Init (&argc, &argv);
assert (MPI_SUCCESS==ierr);
/* FIXME: In fact we dont know if MPI_Init replaced the argv
completely and who is responsible for freeing these
resources. So we do not attempt to free them. */
return scm_from_comm (MPI_COMM_WORLD);
}
char *
gdbscm_exception_message_to_string (SCM exception)
{
SCM port = scm_open_output_string ();
SCM key, args;
char *result;
gdb_assert (gdbscm_is_exception (exception));
key = gdbscm_exception_key (exception);
args = gdbscm_exception_args (exception);
if (scm_is_eq (key, with_stack_error_symbol)
/* Don't crash on a badly generated gdb:with-stack exception. */
&& scm_is_pair (args)
&& scm_is_pair (scm_cdr (args)))
{
key = scm_car (args);
args = scm_cddr (args);
}
gdbscm_print_exception_message (port, SCM_BOOL_F, key, args);
result = gdbscm_scm_to_c_string (scm_get_output_string (port));
scm_close_port (port);
return result;
}
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;
}
/*! \brief Process a Scheme error into the log and/or a GError
* \par Function Description
* Process a captured Guile exception with the given \a s_key and \a
* s_args, and optionally the stack trace \a s_stack. The stack trace
* and source location are logged, and if a GError return location \a
* err is provided, it is populated with an informative error message.
*/
static void
process_error_stack (SCM s_stack, SCM s_key, SCM s_args, GError **err) {
char *long_message;
char *short_message;
SCM s_port, s_subr, s_message, s_message_args, s_rest, s_location;
/* Split s_args up */
s_rest = s_args;
s_subr = scm_car (s_rest); s_rest = scm_cdr (s_rest);
s_message = scm_car (s_rest); s_rest = scm_cdr (s_rest);
s_message_args = scm_car (s_rest); s_rest = scm_cdr (s_rest);
/* Capture short error message */
s_port = scm_open_output_string ();
scm_display_error_message (s_message, s_message_args, s_port);
short_message = scm_to_utf8_string (scm_get_output_string (s_port));
scm_close_output_port (s_port);
/* Capture long error message (including possible backtrace) */
s_port = scm_open_output_string ();
if (scm_is_true (scm_stack_p (s_stack))) {
scm_puts (_("\nBacktrace:\n"), s_port);
scm_display_backtrace (s_stack, s_port, SCM_BOOL_F, SCM_BOOL_F);
scm_puts ("\n", s_port);
}
s_location = SCM_BOOL_F;
#ifdef HAVE_SCM_DISPLAY_ERROR_STACK
s_location = s_stack;
#endif /* HAVE_SCM_DISPLAY_ERROR_STACK */
#ifdef HAVE_SCM_DISPLAY_ERROR_FRAME
s_location =
scm_is_true (s_stack) ? scm_stack_ref (s_stack, SCM_INUM0) : SCM_BOOL_F;
#endif /* HAVE_SCM_DISPLAY_ERROR_FRAME */
scm_display_error (s_location, s_port, s_subr,
s_message, s_message_args, s_rest);
long_message = scm_to_utf8_string (scm_get_output_string (s_port));
scm_close_output_port (s_port);
/* Send long message to log */
s_log_message ("%s", long_message);
/* Populate any GError */
g_set_error (err, EDA_ERROR, EDA_ERROR_SCHEME, "%s", short_message);
}
static Expr* sub(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("no arguments passed to - (expected at least 1)");
// unary case
if(scm_cdr(args) == EMPTY_LIST) {
Expr* v = scm_car(args);
if(scm_is_int(v)) return scm_mk_int(-scm_ival(v));
if(scm_is_real(v)) return scm_mk_int(-scm_rval(v));
return scm_mk_error("wrong type of argument to -");
}
Expr* first = scm_car(args);
if(!scm_is_num(first)) return scm_mk_error("wrong type of argument to -");
bool exact = scm_is_int(first);
double dbuf = exact ? scm_ival(first) : scm_rval(first);
long long lbuf = exact ? scm_ival(first) : 0;
args = scm_cdr(args);
while(scm_is_pair(args)) {
Expr* cur = scm_car(args);
if(scm_is_int(cur)) {
lbuf -= scm_ival(cur);
dbuf -= scm_ival(cur);
} else if(scm_is_real(cur)) {
exact = false;
dbuf -= scm_rval(cur);
} else {
return scm_mk_error("Wrong type of argument to +");
}
args = scm_cdr(args);
}
if(args != EMPTY_LIST) {
return scm_mk_error("args to + aren't a proper list");
}
return exact ? scm_mk_int(lbuf) : scm_mk_real(dbuf);
}
static Expr* p_procedure(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("primitive-procedure? expects an argument");
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("primitive-procedure? expects only 1 argument");
Expr* fst = scm_car(args);
return (fst->tag == ATOM && fst->atom.type == FFUNC) ? TRUE : FALSE;
}
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);
}
static Expr* c_procedure(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("compound-procedure? expects an argument");
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("compound-procedure? expects only 1 argument");
Expr* fst = scm_car(args);
return fst->tag == CLOSURE ? TRUE : FALSE;
}
static void
check_list_elements(ScmObj lst, bool (*check)(ScmObj elm))
{
ScmObj l = SCM_OBJ_INIT;
SCM_REFSTK_INIT_REG(&lst,
&l);
for (l = lst; scm_pair_p(l); l = scm_cdr(l))
TEST_ASSERT_TRUE(check(scm_car(l)));
}
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 Expr* real(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("No args passed to real? (expected 1)");
Expr* fst = scm_car(args);
Expr* rst = scm_cdr(args);
if(rst != EMPTY_LIST) return scm_mk_error("Too many args passed to real? (expected 1)");
return scm_is_real(fst) ? TRUE : FALSE;
}
static Expr* c_env(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("closure-env expects an argument");
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("closure-env expects only 1 argument");
Expr* fst = scm_car(args);
if(fst->tag != CLOSURE) return scm_mk_error("argument to closure-env is not a closure");
return scm_closure_env(fst);
}
int closure_execvl(closure_t *closure, const char *fmt, va_list args, pointer cell)
{
pointer head, result;
scheme *sc = closure->sc;
/* Convert the C args to Scheme. */
if (fmt) {
head = vpack(sc, fmt, args);
} else {
head = sc->NIL;
}
/* Append args to the list */
if (head == sc->NIL) {
/* args is the only thing on the list */
head = _cons(sc, cell, sc->NIL, 0);
} else {
/* Protect the list while allocating for _cons */
sc->vptr->protect(sc, head);
/* Find the end of the list */
pointer tail = head;
while (scm_cdr(sc, tail) != sc->NIL) {
tail = scm_cdr(sc, tail);
}
/* Append the args to the tail of the list */
tail->_object._cons._cdr = _cons(sc, cell, sc->NIL, 0);
/* Unprotect the list now that we're done allocating. */
sc->vptr->unprotect(sc, head);
}
/* Evaluate the closure. */
result = closure_exec_with_scheme_args(closure, head);
/* Translate the result to an int. */
return closure_translate_result(closure->sc, result);
}
static Expr* env_values(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("env-values expects an argument");
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("env-values expects only 1 argument");
Expr* fst = scm_car(args);
if(fst == FALSE) return EMPTY_LIST;
if(!scm_is_env(fst)) return scm_mk_error("env-values expects an environment");
return scm_caddr(fst);
}
static Expr* inexact(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("No args passed to inexact? (expected 1)");
Expr* fst = scm_car(args);
Expr* rst = scm_cdr(args);
if(rst != EMPTY_LIST) return scm_mk_error("Too many args passed to inexact? (expected 1)");
if(number(args) != TRUE) return scm_mk_error("Argument to inexact? is not a number");
return scm_is_real(fst) ? TRUE : FALSE;
}
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;
}
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;
}
SCM make_tensor(SCM scm_type, SCM scm_shape, SCM scm_size, SCM scm_source)
{
SCM retval;
struct tf_tensor_t *self = (struct tf_tensor_t *)scm_gc_calloc(sizeof(struct tf_tensor_t), "make-tensor");
SCM_NEWSMOB(retval, tf_tensor_tag, self);
int type = scm_to_int(scm_type);
int num_dims = scm_to_int(scm_length(scm_shape));
int64_t *dims = scm_gc_malloc_pointerless(sizeof(int64_t) * num_dims, "make-tensor");
int count = 1;
for (int i=0; i<num_dims; i++) {
dims[i] = scm_to_int(scm_car(scm_shape));
count = count * dims[i];
scm_shape = scm_cdr(scm_shape);
};
if (type == TF_STRING) {
SCM* pointer = scm_to_pointer(scm_source);
size_t encoded_size = 0;
for (int i=0; i<count; i++) {
encoded_size += TF_StringEncodedSize(scm_c_string_length(*pointer)) + 8;
pointer++;
};
self->tensor = TF_AllocateTensor(type, dims, num_dims, encoded_size);
int64_t *offsets = TF_TensorData(self->tensor);
int offset = 0;
void *result = offsets + count;
pointer = scm_to_pointer(scm_source);
encoded_size = encoded_size - count * sizeof(int64_t);
for (int i=0; i<count; i++) {
char *str = scm_to_locale_string(*pointer);
int len = TF_StringEncodedSize(scm_c_string_length(*pointer));
*offsets++ = offset;
TF_StringEncode(str, scm_c_string_length(*pointer), result, encoded_size, status());
free(str);
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("make-tensor", TF_Message(_status), SCM_EOL);
offset += len;
encoded_size -= len;
result += len;
pointer++;
};
} else {
self->tensor = TF_AllocateTensor(type, dims, num_dims, scm_to_int(scm_size));
memcpy(TF_TensorData(self->tensor), scm_to_pointer(scm_source), scm_to_int(scm_size));
};
return retval;
}
SCM llvm_build_call(SCM scm_function, SCM scm_llvm, SCM scm_return_type, SCM scm_function_name, SCM scm_argument_types, SCM scm_values)
{
SCM retval;
struct llvm_function_t *function = get_llvm_function(scm_function);
struct llvm_module_t *llvm = get_llvm(scm_llvm);
char *function_name = scm_to_locale_string(scm_function_name);
LLVMValueRef function_pointer = LLVMAddFunction(llvm->module, function_name, function_type(scm_return_type, scm_argument_types));
free(function_name);
// LLVMAddFunctionAttr(function_pointer, LLVMExternalLinkage);
int n_values = scm_ilength(scm_values);
LLVMValueRef *values = scm_gc_malloc_pointerless(n_values * sizeof(LLVMValueRef), "llvm-build-call");
for (int i=0; i<n_values; i++) {
values[i] = get_llvm_value(scm_car(scm_values))->value;
scm_values = scm_cdr(scm_values);
};
struct llvm_value_t *result = (struct llvm_value_t *)scm_gc_calloc(sizeof(struct llvm_value_t), "llvmvalue");
SCM_NEWSMOB(retval, llvm_value_tag, result);
result->value = LLVMBuildCall(function->builder, function_pointer, values, n_values, "x");
return retval;
}
static Expr* str(Expr* args) {
assert(args);
int len = scm_list_len(args);
if(len < 0) return scm_mk_error("string expects a proper list as its arguments");
char* buf = malloc(len + 1);
if(!buf) return OOM;
int i = 0;
while(args != EMPTY_LIST) {
Expr* c = scm_car(args);
if(!scm_is_char(c)) {
i = -1;
break;
}
buf[i++] = scm_cval(c);
args = scm_cdr(args);
}
buf[len] = '\0';
if(i == -1) {
free(buf);
return scm_mk_error("string expects all its args to be chars");
}
Expr* toRet = scm_alloc();
if(toRet) {
toRet->tag = ATOM;
toRet->atom.type = STRING;
toRet->atom.sval = buf;
return toRet;
}
return OOM;
}
