static void
datum_print (repv stream, repv arg)
{
if (arg == Qnil)
{
DEFSTRING (eol, "()");
rep_stream_puts (stream, rep_PTR (rep_VAL (&eol)), 2, rep_TRUE);
}
else
{
repv printer = Fassq (DATUM_ID (arg), printer_alist);
if (printer && rep_CONSP (printer) && rep_CDR (printer) != Qnil)
rep_call_lisp2 (rep_CDR (printer), arg, stream);
else if (rep_SYMBOLP (DATUM_ID (arg)))
{
rep_stream_puts (stream, "#<datum ", -1, rep_FALSE);
rep_stream_puts (stream, rep_PTR (rep_SYM (DATUM_ID (arg))->name), -1, rep_TRUE);
rep_stream_putc (stream, '>');
}
else
rep_stream_puts (stream, "#<datum>", -1, rep_FALSE);
}
}
/* Return true iff structure S exports a binding of symbol VAR that it
inherits from one of its opened structures */
static rep_bool
structure_exports_inherited_p (rep_struct *s, repv var)
{
if (s->car & rep_STF_EXPORT_ALL)
return rep_TRUE;
else
{
repv tem = s->inherited;
while (rep_CONSP (tem))
{
if (rep_CAR (tem) == var)
return rep_TRUE;
tem = rep_CDR (tem);
}
return rep_FALSE;
}
}
static void
make_argv (repv list, int *argc, char ***argv)
{
int c = rep_INT (Flength (list)), i;
char **v;
v = (char **)rep_alloc ((c+1) * sizeof(char**));
for (i = 0; i < c; i++, list = rep_CDR (list))
{
if (!rep_STRINGP (rep_CAR (list)))
{
rep_free ((char *)v);
return;
}
v[i] = strdup (rep_STR (rep_CAR (list)));
}
v[c] = NULL;
*argv = v;
*argc = c;
}
rep_struct_node *
rep_search_imports (rep_struct *s, repv var)
{
rep_struct_node *n = lookup_cache (s, var);
if (n != 0)
return n;
else
{
repv imports = s->imports;
while (rep_CONSP (imports))
{
n = lookup_recursively (rep_CAR (imports), var);
if (n != 0)
{
enter_cache (s, n);
return n;
}
imports = rep_CDR (imports);
}
return 0;
}
}
static char *
completion_generator (char *word, int state)
{
if (state == 0)
{
repv fun = completion_fun;
if (fun == Qnil)
/* backwards compatibility, ugh */
fun = Fsymbol_value (Qrl_completion_generator, Qt);
if (Ffunctionp (fun) != Qnil)
{
completions = (rep_call_with_barrier
(Ffuncall, rep_list_2 (fun, rep_string_dup (word)),
rep_TRUE, 0, 0, 0));
}
else
{
repv re = Fquote_regexp (rep_string_dup (word));
repv boundp = Fsymbol_value (Qboundp, Qt);
completions = Fapropos (rep_concat2("^", rep_STR(re)),
boundp, Qnil);
}
if (completions == rep_NULL)
completions = Qnil;
}
if (completions != Qnil && rep_CONSP(completions)
&& (rep_SYMBOLP(rep_CAR(completions))
|| rep_STRINGP(rep_CAR(completions))))
{
repv string = rep_CAR(completions);
if (rep_SYMBOLP(string))
string = rep_SYM(string)->name;
completions = rep_CDR(completions);
return strdup (rep_STR(string));
}
else
return 0;
}
static char *
rep_ffi_marshal (unsigned int type_id, repv value, char *ptr)
{
rep_ffi_type *type = ffi_types[type_id];
switch (type->subtype)
{
DEFSTRING (err, "unknown ffi type id");
DEFSTRING (err2, "ffi struct expected a vector or list");
case rep_FFI_PRIMITIVE:
switch (type->type->type)
{
case FFI_TYPE_VOID:
return ptr;
case FFI_TYPE_INT:
*(int *)ptr = (int) rep_get_long_int (value);
return ptr + sizeof (int);
case FFI_TYPE_FLOAT:
*(float *)ptr = (float) rep_get_float (value);
return ptr + sizeof (float);
case FFI_TYPE_DOUBLE:
*(double *)ptr = (double) rep_get_float (value);
return ptr + sizeof (double);
#if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE
case FFI_TYPE_LONGDOUBLE:
*(long double *)ptr = (long double) rep_get_float (value);
return ptr + sizeof (long double);
#endif
case FFI_TYPE_UINT8:
*(uint8_t *)ptr = (uint8_t) rep_get_long_int (value);
return ptr + sizeof (uint8_t);
case FFI_TYPE_SINT8:
*(int8_t *)ptr = (int8_t) rep_get_long_int (value);
return ptr + sizeof (int8_t);
case FFI_TYPE_UINT16:
*(uint16_t *)ptr = (uint16_t) rep_get_long_int (value);
return ptr + sizeof (uint16_t);
case FFI_TYPE_SINT16:
*(int16_t *)ptr = (int16_t) rep_get_long_int (value);
return ptr + sizeof (int16_t);
case FFI_TYPE_UINT32:
*(uint32_t *)ptr = (uint32_t) rep_get_long_int (value);
return ptr + sizeof (uint32_t);
case FFI_TYPE_SINT32:
*(int32_t *)ptr = (int32_t) rep_get_long_int (value);
return ptr + sizeof (int32_t);
case FFI_TYPE_UINT64:
*(uint64_t *)ptr = (uint64_t) rep_get_longlong_int (value);
return ptr + sizeof (uint64_t);
case FFI_TYPE_SINT64:
*(int64_t *)ptr = (int64_t) rep_get_longlong_int (value);
return ptr + sizeof (int64_t);
case FFI_TYPE_POINTER:
*(void **)ptr = (rep_STRINGP(value)) ? rep_STR (value) : rep_get_pointer (value);
return ptr + sizeof (void *);
case FFI_TYPE_STRUCT: /* FIXME: */
default:
Fsignal (Qerror, rep_list_2 (rep_VAL (&err),
rep_MAKE_INT (type_id)));
return NULL;
}
/* not reached */
case rep_FFI_STRUCT: {
rep_ffi_struct *s = (rep_ffi_struct *) type;
rep_GC_root gc_value;
int i;
rep_PUSHGC (gc_value, value);
for (i = 0; i < s->n_elements; i++)
{
repv elt;
if (rep_VECTORP (value))
elt = rep_VECTI (value, i);
else if (rep_CONSP (value)) {
elt = rep_CAR (value);
value = rep_CDR (value);
} else {
rep_POPGC;
Fsignal (Qerror, rep_list_2 (rep_VAL (&err2), value));
return NULL;
}
ptr = rep_ffi_marshal (s->element_ids[i], elt, ptr);
if (ptr == NULL) {
rep_POPGC;
return NULL;
}
}
rep_POPGC;
return ptr;
}
case rep_FFI_ALIAS: {
rep_ffi_alias *s = (rep_ffi_alias *) type;
if (s->conv_in != rep_NULL) {
value = rep_call_lisp1 (s->conv_in, value);
if (value == rep_NULL)
return NULL;
}
return rep_ffi_marshal (s->base, value, ptr);
}
default:
Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id)));
return NULL;
}
}
/* Create a barrier (closed if CLOSED is true, open otherwise), then
call CALLBACK with ARG as its argument. The barrier will be in place
for the duration of the call to CALLBACK.
If either of IN or OUT aren't null pointers then they will be called
when the barrier is crossed (while invoking a continuation). Closed
barriers are never crossed. DATA is passed to both IN and OUT
functions when they are called.
The IN function is called when control passes from above barrier on
the stack to below; OUT when control passes from below to above. */
repv
rep_call_with_barrier (repv (*callback)(repv), repv arg,
rep_bool closed, void (*in)(void *),
void (*out)(void *), void *data)
{
repv ret;
rep_barrier b;
memset (&b, 0, sizeof (b));
b.point = (char *) &b;
#if STACK_DIRECTION > 0
b.point += sizeof (rep_barrier); /* don't want to save barrier */
#endif
b.root = root_barrier;
b.in = in;
b.out = out;
b.data = data;
b.closed = closed;
b.depth = barriers ? barriers->depth + 1 : 1;
b.next = barriers;
barriers = &b;
if (closed)
root_barrier = &b;
DB(("with-barrier[%s]: in %p (%d)\n",
closed ? "closed" : "open", &b, b.depth));
ret = callback (arg);
if (closed)
{
rep_thread *ptr;
again:
if (rep_throw_value == exit_barrier_cell)
{
DB (("caught barrier exit throw\n"));
rep_throw_value = rep_CDR (exit_barrier_cell);
ret = (rep_throw_value == rep_NULL) ? Qnil : rep_NULL;
rep_CDR (exit_barrier_cell) = Qnil;
}
if (rep_throw_value == rep_NULL && b.active != 0)
{
/* An active thread exited. Calling thread_delete () on the
active thread will call thread_invoke (). That will
exit if there are no more runnable threads. */
DB (("deleting active thread %p\n", b.active));
thread_delete (b.active);
goto again;
}
if (b.targeted)
{
/* Invalidate any continuations that require this barrier */
rep_continuation *c;
for (c = continuations; c != 0; c = c->next)
{
if (c->root == &b)
c->car |= CF_INVALID;
}
}
for (ptr = b.head; ptr != 0; ptr = ptr->next)
ptr->car |= TF_EXITED;
for (ptr = b.susp_head; ptr != 0; ptr = ptr->next)
ptr->car |= TF_EXITED;
if (b.active != 0)
b.active->car |= TF_EXITED;
}
DB(("with-barrier[%s]: out %p (%d)\n",
closed ? "closed" : "open", &b, b.depth));
barriers = b.next;
root_barrier = b.root;
return ret;
}
/* Called from main(). */
bool
sys_init(char *program_name)
{
int argc;
char **argv;
repv head, *last;
gtk_set_locale ();
if (!batch_mode_p ())
setpgid (0, 0);
make_argv (Fcons (Fsymbol_value (Qprogram_name, Qt),
Fsymbol_value (Qcommand_line_args, Qt)), &argc, &argv);
/* We need to initialise GTK now. The rep-gtk library will
not reinitialise it.. */
gtk_init (&argc, &argv);
argc--; argv++;
head = Qnil;
last = &head;
while(argc > 0)
{
*last = Fcons(rep_string_copy(*argv), Qnil);
last = &rep_CDR(*last);
argc--;
argv++;
}
Fset (Qcommand_line_args, head);
def_font_str = rep_VAL (&def_font_str_data);
#ifdef HAVE_X11
get_resources (program_name);
#endif
get_options ();
use_options ();
color_map = gdk_colormap_get_system ();
gtk_meta_mod = gtk_find_meta ();
/* Loading the gtk rep library will replace the usual
event loop with one that works with GTK. */
rep_INTERN(gtk_feature);
#if rep_INTERFACE >= 9
Frequire (Qgtk_feature);
#else
Fload (rep_string_copy ("gtk"), Qnil, Qnil, Qnil, Qnil);
#endif
if (!rep_throw_value)
{
/* Find the gtkobj<->lispobj converters */
gtk_jade_wrap_gtkobj = rep_find_dl_symbol (Qgtk_feature, "sgtk_wrap_gtkobj");
gtk_jade_get_gtkobj = rep_find_dl_symbol (Qgtk_feature, "sgtk_get_gtkobj");
gtk_jade_callback_postfix = rep_find_dl_symbol (Qgtk_feature, "sgtk_callback_postfix");
assert (gtk_jade_wrap_gtkobj != 0
&& gtk_jade_get_gtkobj != 0
&& gtk_jade_callback_postfix != 0);
return true;
}
else
return false;
}
repv gh_cdr(repv x)
{
return rep_CONSP (x) ? rep_CDR (x) : rep_undefined_value;
}
