static SCM alsa_cards(void) {
// compile list of available cards
int card;
char buf[32];
char *pt;
SCM list, alist;
snd_ctl_card_info_t *info;
snd_ctl_card_info_alloca(&info);
card = -1;
list = SCM_EOL;
while (1) {
if ((snd_card_next(&card) < 0) || (card < 0)) break;
sprintf(buf, "hw:%d", card);
alist = SCM_EOL;
alist = scm_assq_set_x(alist, SYM("dev"),
scm_from_locale_string(buf));
snd_card_get_name(card, &pt);
alist = scm_assq_set_x(alist, SYM("name"),
scm_take_locale_string(pt));
list = scm_cons(alist, list);
scm_remember_upto_here_1(alist);
}
scm_remember_upto_here_1(list);
return list;
}
static SCM decode_timestamp(const char *string) {
const char *here;
int year, month, day, hour, min;
double sec;
SCM rtn;
here = string;
year = atoi(here);
here = index(here, '-') + 1;
month = atoi(here);
here = index(here, '-') + 1;
day = atoi(here);
if (index(here, ':') == NULL) hour = min = sec = 0;
else {
here = index(here, ' ') + 1;
hour = atoi(here);
here = index(here, ':') + 1;
min = atoi(here);
here = index(here, ':') + 1;
sec = atof(here);
}
rtn = local_time_intern(year, month, day, hour, min, sec);
if (rtn == SCM_BOOL_F) log_msg("BAD TIME: '%s' %d-%d-%d %d:%d:%f\n",
string, year, month, day, hour, min, sec);
scm_remember_upto_here_1(rtn);
return rtn;
}
static SCM pg_done(SCM res) {
struct pg_res *pgr;
scm_assert_smob_type(pg_res_tag, res);
pgr = (struct pg_res *)SCM_SMOB_DATA(res);
scm_remember_upto_here_1(res);
return (pgr->res == NULL ? SCM_BOOL_T : SCM_BOOL_F);
}
static int
bpscm_print_breakpoint_smob (SCM self, SCM port, scm_print_state *pstate)
{
breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self);
struct breakpoint *b = bp_smob->bp;
gdbscm_printf (port, "#<%s", breakpoint_smob_name);
/* Only print what we export to the user.
The rest are possibly internal implementation details. */
gdbscm_printf (port, " #%d", bp_smob->number);
/* Careful, the breakpoint may be invalid. */
if (b != NULL)
{
gdbscm_printf (port, " %s %s %s",
bpscm_type_to_string (b->type),
bpscm_enable_state_to_string (b->enable_state),
b->silent ? "silent" : "noisy");
gdbscm_printf (port, " hit:%d", b->hit_count);
gdbscm_printf (port, " ignore:%d", b->ignore_count);
if (b->addr_string != NULL)
gdbscm_printf (port, " @%s", b->addr_string);
}
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/*! \brief Runs a page hook.
* \par Function Description
* Runs a hook called \a name, which should expect the single #PAGE \a
* page as its argument.
*
* \param name name of hook to run
* \param page #PAGE argument for hook.
*/
void
g_run_hook_page (const char *name, PAGE *page)
{
SCM args = scm_list_1 (edascm_from_page (page));
scm_run_hook (g_get_hook_by_name (name), args);
scm_remember_upto_here_1 (args);
}
static SCM fetch_node(SCM smob, SCM args) {
MAKE_NODE * node;
SCM payload;
char *buf;
node = (MAKE_NODE *)SCM_SMOB_DATA(smob);
scm_lock_mutex(node->mutex);
if (!node->dirty) {
payload = node->payload;
scm_unlock_mutex(node->mutex);
return payload;
}
//log_msg("REGENERATE %08x\n", (unsigned long)smob);
node->dirty = 0;
switch (node->type) {
case TYPE_DATUM: break;
case TYPE_FILE:
buf = load_from_file(node->filepath);
if (buf != NULL)
node->payload = scm_take_locale_string(buf);
else node->payload = SCM_BOOL_F;
break;
case TYPE_CHAIN:
node->payload = scm_apply_0(node->callback, args);
break;
}
payload = node->payload;
scm_unlock_mutex(node->mutex);
scm_remember_upto_here_2(smob, args);
scm_remember_upto_here_1(payload);
return payload;
}
static SCM dispatch_event(void *data) {
SCM action = *((SCM *)data);
scm_call_0(action);
scm_gc_unprotect_object(action);
scm_remember_upto_here_1(action);
return SCM_BOOL_T;
}
static SCM gunzip(SCM smob) {
DEFLATE_BLOB *blob;
char *buf;
int ret;
SCM out;
z_stream strm;
blob = (DEFLATE_BLOB *)SCM_SMOB_DATA(smob);
strm.zalloc = Z_NULL;
strm.zfree = Z_NULL;
strm.opaque = Z_NULL;
strm.avail_in = 0;
strm.next_in = Z_NULL;
ret = inflateInit(&strm);
if (ret != Z_OK) {
log_msg("zlib: inflate init failed\n");
return SCM_BOOL_F;
}
buf = (char *)malloc(blob->orig_len);
strm.total_in = strm.avail_in = blob->zip_len;
strm.total_out = strm.avail_out = blob->orig_len;
strm.next_in = (unsigned char *)blob->payload;
strm.next_out = (unsigned char *)buf;
inflate(&strm, Z_FINISH);
inflateEnd(&strm);
out = scm_from_utf8_stringn(buf, blob->orig_len);
free(buf);
return out;
scm_remember_upto_here_1(out);
}
/*! \brief Add a directory to the Guile load path.
* \par Function Description
* Prepends \a s_path to the Guile system '%load-path', after
* expanding environment variables.
*
* \param [in] s_path Path to be added.
* \return SCM_BOOL_T.
*/
SCM g_rc_scheme_directory(SCM s_path)
{
char *temp;
gchar *expanded;
SCM s_load_path_var;
SCM s_load_path;
SCM_ASSERT (scm_is_string (s_path), s_path,
SCM_ARG1, "scheme-directory");
/* take care of any shell variables */
temp = scm_to_utf8_string (s_path);
expanded = s_expand_env_variables (temp);
s_path = scm_from_utf8_string (expanded);
free (temp);
g_free (expanded);
s_load_path_var = scm_c_lookup ("%load-path");
s_load_path = scm_variable_ref (s_load_path_var);
scm_variable_set_x (s_load_path_var, scm_cons (s_path, s_load_path));
scm_remember_upto_here_2 (s_load_path_var, s_load_path);
scm_remember_upto_here_1 (s_path);
return SCM_BOOL_T;
}
/*! \brief Runs a object hook with a single OBJECT.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with a single-element list containing only \a obj.
*
* \see g_run_hook_object_list()
*
* \param name name of hook to run.
* \param obj #OBJECT argument for hook.
*/
void
g_run_hook_object (const char *name, OBJECT *obj)
{
SCM args = scm_list_1 (scm_list_1 (edascm_from_object (obj)));
scm_run_hook (g_get_hook_by_name (name), args);
scm_remember_upto_here_1 (args);
}
static int
pascm_print_param_smob (SCM self, SCM port, scm_print_state *pstate)
{
param_smob *p_smob = (param_smob *) SCM_SMOB_DATA (self);
SCM value;
gdbscm_printf (port, "#<%s", param_smob_name);
gdbscm_printf (port, " %s", p_smob->name);
if (! pascm_is_valid (p_smob))
scm_puts (" {invalid}", port);
gdbscm_printf (port, " %s ", pascm_param_type_name (p_smob->type));
value = pascm_param_value (p_smob->type, &p_smob->value,
GDBSCM_ARG_NONE, NULL);
scm_display (value, port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Change the size of a port's bytevector to NEW_SIZE. This doesn't
change `read_buf_size'. */
static void
st_resize_port (scm_t_port *pt, scm_t_off new_size)
{
SCM old_stream = SCM_PACK (pt->stream);
const signed char *src = SCM_BYTEVECTOR_CONTENTS (old_stream);
SCM new_stream = scm_c_make_bytevector (new_size);
signed char *dst = SCM_BYTEVECTOR_CONTENTS (new_stream);
unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream);
unsigned long int min_size = min (old_size, new_size);
scm_t_off offset = pt->write_pos - pt->write_buf;
pt->write_buf_size = new_size;
memcpy (dst, src, min_size);
scm_remember_upto_here_1 (old_stream);
/* reset buffer. */
{
pt->stream = SCM_UNPACK (new_stream);
pt->read_buf = pt->write_buf = (unsigned char *)dst;
pt->read_pos = pt->write_pos = pt->write_buf + offset;
pt->write_end = pt->write_buf + pt->write_buf_size;
pt->read_end = pt->read_buf + pt->read_buf_size;
}
}
static SCM pg_cell(SCM row, SCM col_key) {
SCM cell;
cell = scm_assq_ref(row, col_key);
scm_remember_upto_here_1(cell);
scm_remember_upto_here_2(row, col_key);
return cell;
}
static SCM pg_fields(SCM res) {
struct pg_res *pgr;
scm_assert_smob_type(pg_res_tag, res);
pgr = (struct pg_res *)SCM_SMOB_DATA(res);
scm_remember_upto_here_1(res);
return pgr->fields;
}
static SCM body_proc(void *data) {
SCM obj;
char *linebuf = (char *)data;
obj = scm_c_eval_string(linebuf);
if (obj == SCM_UNSPECIFIED) return SCM_BOOL_T;
scm_call_1(console_display, obj);
scm_remember_upto_here_1(obj);
return SCM_BOOL_T;
}
static SCM pg_clear(SCM res) {
struct pg_res *pgr;
scm_assert_smob_type(pg_res_tag, res);
pgr = (struct pg_res *)SCM_SMOB_DATA(res);
if (pgr->res != NULL) PQclear(pgr->res);
pgr->res = NULL;
scm_remember_upto_here_1(res);
return SCM_UNSPECIFIED;
}
static void invalidate(MAKE_NODE *node) {
SCM cursor;
node->dirty = 1;
cursor = node->ascendants;
while (cursor != SCM_EOL) {
invalidate((MAKE_NODE *)SCM_SMOB_DATA(SCM_CAR(cursor)));
cursor = SCM_CDR(cursor);
}
scm_remember_upto_here_1(cursor);
return;
}
static SCM sched_has_entry(SCM tag) {
SCM out;
char *target = scm_to_locale_string(tag);
scm_remember_upto_here_1(tag);
pthread_mutex_lock(&pmutex);
SCHED_EVENT *event = find_node(target);
free(target);
if (event != NULL) out = SCM_BOOL_T;
else out = SCM_BOOL_F;
pthread_mutex_unlock(&pmutex);
return out;
}
static SCM sched_entry_time(SCM tag) {
SCM out;
char *target = scm_to_locale_string(tag);
scm_remember_upto_here_1(tag);
pthread_mutex_lock(&pmutex);
SCHED_EVENT *event = find_node(target);
free(target);
if (event != NULL)
out = time_at(scm_from_double(event->clock / (double)TIME_RES));
else out = SCM_BOOL_F;
pthread_mutex_unlock(&pmutex);
return out;
}
/*! \brief Runs a object hook with a single OBJECT.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with a single-element list containing only \a obj.
*
* \see g_run_hook_object_list()
*
* \param name name of hook to run.
* \param obj #OBJECT argument for hook.
*/
void
g_run_hook_object (GschemToplevel *w_current, const char *name, OBJECT *obj)
{
scm_dynwind_begin (0);
g_dynwind_window (w_current);
SCM expr = scm_list_3 (run_hook_sym,
g_get_hook_by_name (name),
scm_list_2 (list_sym, edascm_from_object (obj)));
g_scm_eval_protected (expr, scm_interaction_environment ());
scm_dynwind_end ();
scm_remember_upto_here_1 (expr);
}
static SCM sched_cancel(SCM tag) {
SCM out;
char *target = scm_to_locale_string(tag);
scm_remember_upto_here_1(tag);
pthread_mutex_lock(&pmutex);
SCHED_EVENT *event = find_node(target);
free(target);
if (event != NULL) {
event->state = STATE_CANCELED;
out = SCM_BOOL_T;
}
else out = SCM_BOOL_F;
pthread_mutex_unlock(&pmutex);
return out;
}
static int
arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
{
arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
struct gdbarch *gdbarch = a_smob->gdbarch;
gdbscm_printf (port, "#<%s", arch_smob_name);
gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
ppscm_print_pretty_printer_smob (SCM self, SCM port, scm_print_state *pstate)
{
pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", pretty_printer_smob_name);
scm_write (pp_smob->name, port);
scm_puts (gdbscm_is_true (pp_smob->enabled) ? " enabled" : " disabled",
port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
exscm_print_exception_smob (SCM self, SCM port, scm_print_state *pstate)
{
exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", exception_smob_name);
scm_write (e_smob->key, port);
scm_puts (" ", port);
scm_write (e_smob->args, port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
stscm_print_symtab_smob (SCM self, SCM port, scm_print_state *pstate)
{
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", symtab_smob_name);
gdbscm_printf (port, "%s",
st_smob->symtab != NULL
? symtab_to_filename_for_display (st_smob->symtab)
: "<invalid>");
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
stscm_print_sal_smob (SCM self, SCM port, scm_print_state *pstate)
{
sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (s_smob->symtab_scm);
gdbscm_printf (port, "#<%s ", symtab_smob_name);
scm_write (s_smob->symtab_scm, port);
if (s_smob->sal.line != 0)
gdbscm_printf (port, " line %d", s_smob->sal.line);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
lsscm_print_lazy_string_smob (SCM self, SCM port, scm_print_state *pstate)
{
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s", lazy_string_smob_name);
gdbscm_printf (port, " @%s", hex_string (ls_smob->address));
if (ls_smob->length >= 0)
gdbscm_printf (port, " length %d", ls_smob->length);
if (ls_smob->encoding != NULL)
gdbscm_printf (port, " encoding %s", ls_smob->encoding);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
syscm_print_symbol_smob (SCM self, SCM port, scm_print_state *pstate)
{
symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
if (pstate->writingp)
gdbscm_printf (port, "#<%s ", symbol_smob_name);
gdbscm_printf (port, "%s",
s_smob->symbol != NULL
? SYMBOL_PRINT_NAME (s_smob->symbol)
: "<invalid>");
if (pstate->writingp)
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
ppscm_print_pretty_printer_worker_smob (SCM self, SCM port,
scm_print_state *pstate)
{
pretty_printer_worker_smob *w_smob
= (pretty_printer_worker_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", pretty_printer_worker_smob_name);
scm_write (w_smob->display_hint, port);
scm_puts (" ", port);
scm_write (w_smob->to_string, port);
scm_puts (" ", port);
scm_write (w_smob->children, port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
static int
cmdscm_print_command_smob (SCM self, SCM port, scm_print_state *pstate)
{
command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s", command_smob_name);
gdbscm_printf (port, " %s",
c_smob->name != NULL ? c_smob->name : "{unnamed}");
if (! cmdscm_is_valid (c_smob))
scm_puts (" {invalid}", port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
