/*! \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; }