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;
}
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 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;
}
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* 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* car(Expr* args) {
assert(args);
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("passed more than 1 arg to car");
Expr* arg = scm_car(args);
if(!scm_is_pair(arg)) return scm_mk_error("arg to car must be a pair");
return scm_car(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);
}
static Expr* env_parent(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("env-parent expects an argument");
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("env-parent 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-parent expects an environment");
return scm_car(fst);
}
static Expr* eq(Expr* args) {
assert(args);
if(scm_list_len(args) != 2) return scm_mk_error("eq? expects 2 args");
return scm_car(args) == scm_cadr(args) ? TRUE : FALSE;
}
static Expr* not(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("not expects 1 arg");
return scm_is_true(scm_car(args)) ? FALSE : TRUE;
}
static Expr* boolean(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("boolean? expects 1 arg");
return scm_is_bool(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;
}
VISIBLE void
scm_c_anchor_point_coords (SCM anchor_point, SCM *x, SCM *y)
{
SCM coords = scm_anchor_point_coords_2 (anchor_point);
*x = scm_car (coords);
*y = scm_cadr (coords);
}
/*! \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* 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;
}
// String functions
static Expr* is_str(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("string? expects 1 arg");
return scm_is_string(scm_car(args)) ? TRUE: FALSE;
}
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);
}
/*! \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);
}
SCM Display::scm_draw_image(SCM image, SCM pos) {
#ifdef WITH_SDL
struct image *img = (struct image *) SCM_SMOB_DATA(image);
SDL_Rect p;
p.x = scm_to_int(scm_car(pos));
p.y = scm_to_int(scm_cadr(pos));
printf("%d, %d", img->surface, NULL);
SDL_BlitSurface(img->surface, NULL, get()->m_pScreen, &p);
#endif
}
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 SCM scm_launch_program(SCM prog)
{
scm_dynwind_begin(0);
char *c_path = scm_to_locale_string(scm_car(prog));
scm_dynwind_free(c_path);
fprintf(stderr, "launching program %s\n", c_path);
pid_t pid = fork();
if (pid == 0) {
if (scm_is_false(scm_execlp(scm_car(prog), prog))) {
perror("execl failed");
exit(2);
}
}
else {
fprintf(stderr, "launched %s as pid %d\n", c_path, pid);
}
scm_dynwind_end();
return SCM_UNSPECIFIED;
}
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 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 Expr* str_null(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("string-null? expects 1 arg");
Expr* a = scm_car(args);
if(!scm_is_string(a)) return scm_mk_error("string-null? expects a string");
return scm_sval(a)[0] == '\0' ? 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)));
}
static Expr* chr2int(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("char->integer expects 1 arg");
Expr* fst = scm_car(args);
if(!scm_is_char(fst)) return scm_mk_error("char->integer expects a character");
return scm_mk_int(scm_cval(fst));
}
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);
}