/*! \brief Evaluate a gschem action by name.
* \par Function Description
* Evaluates the action named \a action_name, which should be a UTF-8
* string naming a symbol in the user module. If evaluating the
* action fails, prints a message to the log and returns FALSE;
* otherwise, returns TRUE.
*
* \param w_current Current gschem toplevel structure.
* \param action_name Name of action to evaluate.
*
* \return TRUE on success, FALSE on failure.
*/
gboolean
g_action_eval_by_name (GschemToplevel *w_current, const gchar *action_name)
{
SCM s_eval_action_proc;
SCM s_expr;
SCM s_result;
gboolean result;
g_assert (w_current);
g_assert (action_name);
scm_dynwind_begin (0);
g_dynwind_window (w_current);
/* Get the eval-action procedure */
s_eval_action_proc =
scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("gschem action"),
"eval-action!"));
/* Build expression to evaluate */
/* FIXME use SCM_SYMBOL for quote */
s_expr = scm_list_2 (s_eval_action_proc,
scm_list_2 (scm_from_utf8_symbol ("quote"),
scm_from_utf8_symbol (action_name)));
/* Evaluate and get return value */
s_result = g_scm_eval_protected (s_expr, SCM_UNDEFINED);
result = scm_is_true (s_result);
scm_dynwind_end ();
return result;
}
/*! \brief Evaluate a string as a Scheme expression safely
* \par Function Description
*
* Evaluates a string similarly to scm_eval_string(), but catching
* any errors or exceptions and reporting them via the libgeda
* logging mechanism.
*
* See also g_scm_eval_protected() and g_scm_c_eval_string_protected().
*
* \param str String to evaluate.
*
* \returns Evaluation results or SCM_BOOL_F if exception caught.
*/
SCM g_scm_eval_string_protected (SCM str)
{
SCM expr = scm_list_2 (scm_from_utf8_symbol ("eval-string"),
str);
return g_scm_eval_protected (expr, SCM_UNDEFINED);
}
static SCM
create_subr (int define, const char *name,
unsigned int nreq, unsigned int nopt, unsigned int rest,
SCM (*fcn) (), SCM *generic_loc)
{
SCM ret, sname;
scm_t_bits flags;
scm_t_bits nfree = generic_loc ? 3 : 2;
sname = scm_from_utf8_symbol (name);
flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
if (generic_loc)
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2,
scm_from_pointer (generic_loc, NULL));
if (define)
scm_define (sname, ret);
return ret;
}
/*! \brief Gets a Scheme hook object by name.
* \par Function Description
* Returns the contents of variable with the given name in the (gschem
* core hook). Used for looking up hook objects.
*
* \param name name of hook to lookup.
* \return value found in the (gschem core hook) module.
*/
static SCM
g_get_hook_by_name (const char *name)
{
SCM exp = scm_list_3 (at_sym,
scm_list_3 (gschem_sym, core_sym, hook_sym),
scm_from_utf8_symbol (name));
return g_scm_eval_protected (exp, SCM_UNDEFINED);
}
static PyObject *load_wrapper(PyObject *name_arg)
{
return scm2py(
scm_eval(
scm_list_2(scm_from_utf8_symbol("load"),
py2scm(name_arg)),
scm_current_module()));
}
void init_cache(void) {
make_node_tag = scm_make_smob_type("make-node", sizeof(MAKE_NODE));
scm_set_smob_free(make_node_tag, free_node);
scm_set_smob_mark(make_node_tag, mark_node);
deflate_tag = scm_make_smob_type("gzip-blob", sizeof(DEFLATE_BLOB));
sessions_db = scm_from_locale_string("sessions");
scm_gc_protect_object(sessions_db);
scm_permanent_object(file_sym = scm_from_utf8_symbol("file"));
scm_permanent_object(data_sym = scm_from_utf8_symbol("data"));
scm_permanent_object(stamp_sym = scm_from_utf8_symbol("stamp"));
scm_c_define_gsubr("make-doc", 2, 0, 0, make_doc);
scm_c_define_gsubr("touch-doc", 1, 0, 1, touch_node);
scm_c_define_gsubr("fetch-doc", 1, 0, 1, fetch_node);
scm_c_define_gsubr("touched-doc?", 1, 0, 0, touched_node);
scm_c_define_gsubr("gzip", 1, 0, 0, gzip);
scm_c_define_gsubr("zdeflate", 1, 0, 0, zdeflate);
scm_c_define_gsubr("zdeflate-size", 1, 0, 0, deflate_size);
scm_c_define_gsubr("zdeflate?", 1, 0, 0, is_gzip);
scm_c_define_gsubr("zinflate", 1, 0, 0, gunzip);
log_msg("zlib version %s\n", zlibVersion());
}
static void x_window_invoke_macro(GtkEntry *entry, void *userdata)
{
GSCHEM_TOPLEVEL *w_current = userdata;
SCM interpreter;
interpreter = scm_list_2(scm_from_utf8_symbol("invoke-macro"),
scm_from_utf8_string(gtk_entry_get_text(entry)));
g_scm_eval_protected(interpreter, SCM_UNDEFINED);
gtk_widget_hide(w_current->macro_box);
gtk_widget_grab_focus(w_current->drawing_area);
}
void run_hook(const char *hook_name, SCM args)
{
SCM hook_symb = scm_from_utf8_symbol(hook_name);
SCM hook = scm_eval(hook_symb, scm_interaction_environment());
if (scm_is_false(scm_defined_p(hook_symb, SCM_UNDEFINED))) {
fprintf(stderr, "error: %s undefined\n", hook_name);
return;
}
else if (scm_is_false(scm_hook_p(hook))) {
fprintf(stderr, "error: %s is not a hook!\n", hook_name);
return;
}
if (scm_is_false(scm_hook_empty_p(hook)))
scm_run_hook(hook, args);
}
static void
x_window_invoke_macro (GschemMacroWidget *widget, int response, GschemToplevel *w_current)
{
if (response == GTK_RESPONSE_OK) {
const char *macro = gschem_macro_widget_get_macro_string (widget);
SCM interpreter = scm_list_2(scm_from_utf8_symbol("invoke-macro"),
scm_from_utf8_string(macro));
scm_dynwind_begin (0);
g_dynwind_window (w_current);
g_scm_eval_protected(interpreter, SCM_UNDEFINED);
scm_dynwind_end ();
}
gtk_widget_grab_focus (w_current->drawing_area);
gtk_widget_hide (GTK_WIDGET (widget));
}
static SCM
parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint32 meta)
{
SCM tail = SCM_EOL;
int len;
/* Format: (name opcode word0 word1 ...) */
if (HAS_WORD (4, meta))
len = 5;
else if (HAS_WORD (3, meta))
len = 4;
else if (HAS_WORD (2, meta))
len = 3;
else if (HAS_WORD (1, meta))
len = 2;
else if (HAS_WORD (0, meta))
len = 1;
else
abort ();
switch (len)
{
case 5:
tail = scm_cons (word_type_symbols[WORD_TYPE (4, meta)], tail);
case 4:
tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail);
case 3:
tail = scm_cons (word_type_symbols[WORD_TYPE (2, meta)], tail);
case 2:
tail = scm_cons (word_type_symbols[WORD_TYPE (1, meta)], tail);
case 1:
tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
default:
tail = scm_cons ((meta & OP_DST) ? sym_left_arrow : sym_bang, tail);
tail = scm_cons (scm_from_int (opcode), tail);
tail = scm_cons (scm_from_utf8_symbol (name), tail);
return tail;
}
}
static void py2scm_exception(void)
{
PyObject *ptype = NULL, *pvalue = NULL, *ptraceback = NULL;
PyErr_Fetch(&ptype, &pvalue, &ptraceback);
PyObject *pvalue_str = NULL;
if (pvalue) {
pvalue_str = PyObject_Str(pvalue);
if (pvalue_str == NULL)
PyErr_Clear();
}
scm_throw(scm_from_utf8_symbol("python-exception"),
scm_list_2(scm_from_locale_string(
((PyTypeObject *)ptype)->tp_name),
pvalue_str != NULL && PyObject_IsTrue(pvalue_str)
? scm_from_locale_string(
PyString_AsString(pvalue_str))
: SCM_BOOL_F));
/* does not return */
fprintf(stderr, "*** scm_error shouldn't have returned ***\n");
}
static SCM pg_exec(SCM conn, SCM query) {
struct pg_conn *pgc;
struct pg_res *pgr;
char *query_s;
int i;
SCM res_smob;
scm_assert_smob_type(pg_conn_tag, conn);
pgc = (struct pg_conn *)SCM_SMOB_DATA(conn);
pgr = (struct pg_res *)scm_gc_malloc(sizeof(struct pg_res),
"pg_res");
query_s = scm_to_utf8_string(query);
scm_lock_mutex(pgc->mutex);
pgr->res = PQexec(pgc->conn, query_s);
scm_unlock_mutex(pgc->mutex);
pgr->cursor = 0;
pgr->fields = SCM_EOL;
pgr->types = SCM_EOL;
pgr->nfields = PQnfields(pgr->res);
pgr->tuples = PQntuples(pgr->res);
pgr->cmd_tuples = atoi(PQcmdTuples(pgr->res));
pgr->status = PQresultStatus(pgr->res);
if ((pgr->status == PGRES_FATAL_ERROR) ||
(pgr->status == PGRES_NONFATAL_ERROR)) {
log_msg("PQquery: %s\n", query_s);
log_msg("PQerr: %s", PQresultErrorMessage(pgr->res));
}
free(query_s);
for (i = pgr->nfields - 1; i >= 0; i--) {
pgr->fields = scm_cons(scm_from_utf8_symbol(
PQfname(pgr->res, i)), pgr->fields);
pgr->types = scm_cons(scm_from_unsigned_integer(PQftype(pgr->res, i)),
pgr->types);
}
SCM_NEWSMOB(res_smob, pg_res_tag, pgr);
return res_smob;
}
/*! \brief Parse gschem command-line options.
* \par Function Description
* Parse command line options, displaying usage message or version
* information as required.
*
* \param argc Number of command-line arguments.
* \param argv Array of command-line arguments.
* \return index into \a argv of first non-option argument.
*/
int
parse_commandline(int argc, char *argv[])
{
int ch;
SCM sym_cons = scm_from_utf8_symbol ("cons");
SCM sym_set_x = scm_from_utf8_symbol ("set!");
SCM sym_load_path = scm_from_utf8_symbol ("%load-path");
SCM sym_begin = scm_from_utf8_symbol ("begin");
SCM sym_load = scm_from_utf8_symbol ("load");
SCM sym_eval_string = scm_from_utf8_symbol ("eval-string");
#ifdef HAVE_GETOPT_LONG
while ((ch = getopt_long (argc, argv, GETOPT_OPTIONS, long_options, NULL)) != -1) {
#else
while ((ch = getopt (argc, argv, GETOPT_OPTIONS)) != -1) {
#endif
switch (ch) {
case 'v':
verbose_mode = TRUE;
break;
case 'q':
quiet_mode = TRUE;
break;
case 's':
/* Argument is filename of a Scheme script to be run on gschem
* load. Add the necessary expression to be evaluated after
* loading. */
s_post_load_expr =
scm_cons (scm_list_2 (sym_load,
scm_from_locale_string (optarg)),
s_post_load_expr);
break;
case 'c':
/* Argument is a Scheme expression to be evaluated on gschem
* load. Add the necessary expression to be evaluated after
* loading. */
s_post_load_expr =
scm_cons (scm_list_2 (sym_eval_string,
scm_from_locale_string (optarg)),
s_post_load_expr);
break;
case 'o':
output_filename_s = scm_from_locale_string (optarg);
break;
case 'p':
auto_place_mode = TRUE;
break;
case 'L':
/* Argument is a directory to add to the Scheme load path.
* Add the necessary expression to be evaluated before rc file
* loading. */
s_pre_load_expr =
scm_cons (scm_list_3 (sym_set_x,
sym_load_path,
scm_list_3 (sym_cons,
scm_from_locale_string (optarg),
sym_load_path)),
s_pre_load_expr);
break;
case 'h':
usage(argv[0]);
break;
case 'V':
version ();
break;
case '?':
#ifndef HAVE_GETOPT_LONG
if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) {
fprintf (stderr,
"ERROR: -%c option requires an argument.\n\n",
optopt);
} else if (isprint (optopt)) {
fprintf (stderr, "ERROR: Unknown option -%c.\n\n", optopt);
} else {
fprintf (stderr, "ERROR: Unknown option character `\\x%x'.\n\n",
optopt);
}
#endif
fprintf (stderr, "\nRun `%s --help' for more information.\n", argv[0]);
exit (1);
break;
default:
g_assert_not_reached ();
}
}
if (quiet_mode) {
verbose_mode = FALSE;
}
/* Make sure Scheme expressions can be passed straight to eval */
s_pre_load_expr = scm_cons (sym_begin,
scm_reverse_x (s_pre_load_expr, SCM_UNDEFINED));
scm_gc_protect_object (s_pre_load_expr);
s_post_load_expr = scm_cons (sym_begin,
scm_reverse_x (s_post_load_expr, SCM_UNDEFINED));
scm_gc_protect_object (s_post_load_expr);
return(optind);
}
SCM py2scm(PyObject *value)
{
if (value == Py_None) {
return SCM_UNSPECIFIED;
}
if (PyBool_Check(value)) {
int v = PyObject_IsTrue(value);
if (v == -1)
return NULL;
return scm_from_bool(v);
}
if (PyInt_Check(value)) {
long v = PyInt_AsLong(value);
if (PyErr_Occurred())
return NULL;
return scm_from_long(v);
}
if (PyFloat_Check(value)) {
double v = PyFloat_AsDouble(value);
if (PyErr_Occurred())
return NULL;
return scm_from_double(v);
}
if (PyString_Check(value)) {
const char *s = PyString_AsString(value);
if (s == NULL)
return NULL;
return scm_from_utf8_stringn(s, PyString_Size(value));
}
if (PyUnicode_Check(value)) {
scm_dynwind_begin(0);
PyObject *utf8_str = PyUnicode_AsUTF8String(value);
if (utf8_str == NULL) {
scm_dynwind_end();
return NULL;
}
scm_dynwind_py_decref(utf8_str);
const char *s = PyString_AsString(utf8_str);
if (s == NULL) {
scm_dynwind_end();
return NULL;
}
SCM result = scm_from_utf8_stringn(s, PyString_Size(utf8_str));
scm_dynwind_end();
return result;
}
if (PySequence_Check(value)) {
unsigned int i = PySequence_Size(value);
SCM r = SCM_EOL;
while (i-- > 0) {
PyObject *item = PySequence_GetItem(value, i);
r = scm_cons(py2scm(item), r);
}
return r;
}
if (PyObject_TypeCheck(value, &ProcedureType))
return ((Procedure *)value)->proc;
if (PyCallable_Check(value)) {
SCM gsubr = scm_c_make_gsubr(
"<Python function>", 0, 0, 1, &call_callable);
Py_INCREF(value);
SCM ptr = scm_from_pointer(value, (void (*)(void *))Py_DecRef);
gsubr_alist = scm_acons(gsubr, ptr, gsubr_alist);
return gsubr;
}
char buf[BUFSIZ];
snprintf(buf, BUFSIZ, "Python type \"%.50s\" doesn't have a "
"corresponding Guile type",
value->ob_type->tp_name);
scm_error(scm_from_utf8_symbol("misc-error"), NULL, buf,
SCM_EOL, SCM_EOL);
/* does not return */
fprintf(stderr, "*** scm_error shouldn't have returned ***\n");
return SCM_UNSPECIFIED;
}
