Ejemplo n.º 1
0
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;
}
Ejemplo n.º 2
0
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;
}
Ejemplo n.º 3
0
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;
}
Ejemplo n.º 4
0
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;
}
Ejemplo n.º 5
0
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;
}
Ejemplo n.º 6
0
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);
}
Ejemplo n.º 7
0
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);
}
Ejemplo n.º 8
0
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);
}
Ejemplo n.º 9
0
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;
}
Ejemplo n.º 10
0
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;
}
Ejemplo n.º 11
0
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;
}
Ejemplo n.º 12
0
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);
}
Ejemplo n.º 13
0
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;
}
Ejemplo n.º 14
0
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;
}
Ejemplo n.º 15
0
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);
}
Ejemplo n.º 16
0
/*! \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;
}
Ejemplo n.º 17
0
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;
}
Ejemplo n.º 18
0
// 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;
}
Ejemplo n.º 19
0
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);
}
Ejemplo n.º 20
0
/*! \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);
}
Ejemplo n.º 21
0
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);
}
Ejemplo n.º 22
0
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
}
Ejemplo n.º 23
0
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);
}
Ejemplo n.º 24
0
Archivo: scheme.c Proyecto: nizmic/nwm
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;
}
Ejemplo n.º 25
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;
}
Ejemplo n.º 26
0
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;
}
Ejemplo n.º 27
0
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;
}
Ejemplo n.º 28
0
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)));
}
Ejemplo n.º 29
0
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));
}
Ejemplo n.º 30
0
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);
}