repv
sys_make_color(Lisp_Color *c)
{
if (gdk_color_parse (rep_STR (c->name), &c->color))
{
if (gdk_colormap_alloc_color (color_map, &c->color, 0, 1))
return rep_VAL (c);
else
return Fsignal(Qerror, rep_list_2(rep_VAL(&no_alloc_color),
c->name));
}
else
return Fsignal(Qerror, rep_list_2(rep_VAL(&no_parse_color), c->name));
}
/* Compile a regexp and signal a Lisp error if anything goes wrong. */
void
compile_pattern (Lisp_Object pattern, struct re_pattern_buffer *bufp, char *translate, int backward)
{
char *val;
Lisp_Object dummy;
if (EQ (pattern, last_regexp)
&& translate == bufp->translate /* 92.4.10 by K.Handa */
/* 93.7.13 by K.Handa */
&& NILP (current_buffer->mc_flag) == !bufp->mc_flag
&& (!bufp->syntax_version
|| bufp->syntax_version == syntax_table_version)
&& (!bufp->category_version
|| bufp->category_version == category_table_version))
return;
if (CONSP (pattern)) /* pre-compiled regexp */
{
Lisp_Object compiled;
val = 0;
pattern = XCONS (pattern)->car;
if (CONSP (pattern)
&& (compiled = backward ? XCONS(pattern)->cdr : XCONS(pattern)->car)
&& XTYPE (compiled) == Lisp_Vector
&& XVECTOR (compiled)->size == 4) {
/* set_pattern will set bufp->allocated to NULL */
set_pattern (compiled, bufp, translate);
return;
}
val = "Invalied pre-compiled regexp";
goto invalid_regexp;
}
CHECK_STRING (pattern, 0);
last_regexp = Qnil;
bufp->translate = translate;
bufp->syntax_version = bufp->category_version = 0; /* 93.7.13 by K.Handa */
/* 92.7.10 by T.Enami
'bufp->allocated == 0' means bufp->buffer points to pre-compiled pattern
in a lisp string, which should not be 'realloc'ed. */
if (bufp->allocated == 0) bufp->buffer = 0;
val = re_compile_pattern (XSTRING (pattern)->data,
XSTRING (pattern)->size,
bufp);
if (val)
{
invalid_regexp:
dummy = build_string (val);
while (1)
Fsignal (Qinvalid_regexp, Fcons (dummy, Qnil));
}
last_regexp = pattern;
return;
}
static void
primitive_invoke_continuation (rep_continuation *c, repv ret)
{
char water_mark;
rep_barrier **dest_hist = 0, *dest_root = 0, *anc, *ptr;
int depth;
/* try to find a route from the current root barrier to the
root barrier of the continuation, without crossing any
closed barriers */
dest_root = FIXUP (rep_barrier *, c, c->barriers);
dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth);
depth = trace_barriers (c, dest_hist);
anc = common_ancestor (barriers, dest_hist, depth);
if (anc == 0)
{
DEFSTRING (unreachable, "unreachable continuation");
Fsignal (Qerror, rep_LIST_1 (rep_VAL (&unreachable)));
return;
}
/* Handle any `out' barrier functions */
for (ptr = barriers; ptr != anc; ptr = ptr->next)
{
DB (("invoke: outwards through %p (%d)\n", ptr, ptr->depth));
if (ptr->out != 0)
{
repv cont = rep_VAL (c);
rep_GC_root gc_cont, gc_ret;
rep_PUSHGC (gc_cont, cont);
rep_PUSHGC (gc_ret, ret);
ptr->out (ptr->data);
rep_POPGC; rep_POPGC;
}
}
/* save the return value and recurse up the stack until there's
room to invoke the continuation. Note that invoking this subr
will already have restored the original environment since the
call to Fmake_closure () will have saved its old state.. */
invoked_continuation = c;
invoked_continuation_ret = ret;
invoked_continuation_ancestor = anc;
DB (("invoke: calling continuation %p\n", c));
grow_stack_and_invoke (c, &water_mark);
}
/* You must call this after acquiring the global lock.
acquire_global_lock does it for you. */
static void
post_acquire_global_lock (struct thread_state *self)
{
struct thread_state *prev_thread = current_thread;
/* Do this early on, so that code below could signal errors (e.g.,
unbind_for_thread_switch might) correctly, because we are already
running in the context of the thread pointed by SELF. */
current_thread = self;
if (prev_thread != current_thread)
{
/* PREV_THREAD is NULL if the previously current thread
exited. In this case, there is no reason to unbind, and
trying will crash. */
if (prev_thread != NULL)
unbind_for_thread_switch (prev_thread);
rebind_for_thread_switch ();
/* Set the new thread's current buffer. This needs to be done
even if it is the same buffer as that of the previous thread,
because of thread-local bindings. */
set_buffer_internal_2 (current_buffer);
}
/* We could have been signaled while waiting to grab the global lock
for the first time since this thread was created, in which case
we didn't yet have the opportunity to set up the handlers. Delay
raising the signal in that case (it will be actually raised when
the thread comes here after acquiring the lock the next time). */
if (!NILP (current_thread->error_symbol) && handlerlist)
{
Lisp_Object sym = current_thread->error_symbol;
Lisp_Object data = current_thread->error_data;
current_thread->error_symbol = Qnil;
current_thread->error_data = Qnil;
Fsignal (sym, data);
}
}
static void
setup_config (void)
{
const char *coding_name;
const char *cp;
char *end;
int slen;
Lisp_Object coding_system;
Lisp_Object dos_coding_system;
CHECK_SYMBOL (Vselection_coding_system);
coding_system = NILP (Vnext_selection_coding_system) ?
Vselection_coding_system : Vnext_selection_coding_system;
dos_coding_system = validate_coding_system (coding_system);
if (NILP (dos_coding_system))
Fsignal (Qerror,
list2 (build_string ("Coding system is invalid or doesn't have "
"an eol variant for dos line ends"),
coding_system));
/* Check if we have it cached */
if (!NILP (cfg_coding_system)
&& EQ (cfg_coding_system, dos_coding_system))
return;
cfg_coding_system = dos_coding_system;
/* Set some sensible fallbacks */
cfg_codepage = ANSICP;
cfg_lcid = LOCALE_NEUTRAL;
cfg_clipboard_type = CF_TEXT;
/* Interpret the coding system symbol name */
coding_name = SSDATA (SYMBOL_NAME (cfg_coding_system));
/* "(.*-)?utf-16.*" -> CF_UNICODETEXT */
cp = strstr (coding_name, "utf-16");
if (cp != NULL && (cp == coding_name || cp[-1] == '-'))
{
cfg_clipboard_type = CF_UNICODETEXT;
return;
}
/* "cp[0-9]+.*" or "windows-[0-9]+.*" -> CF_TEXT or CF_OEMTEXT */
slen = strlen (coding_name);
if (slen >= 4 && coding_name[0] == 'c' && coding_name[1] == 'p')
cp = coding_name + 2;
else if (slen >= 10 && memcmp (coding_name, "windows-", 8) == 0)
cp = coding_name + 8;
else
return;
end = (char*)cp;
cfg_codepage = strtol (cp, &end, 10);
/* Error return from strtol() or number of digits < 2 -> Restore the
default and drop it. */
if (cfg_codepage == 0 || (end-cp) < 2 )
{
cfg_codepage = ANSICP;
return;
}
/* Is it the currently active system default? */
if (cfg_codepage == ANSICP)
{
/* cfg_clipboard_type = CF_TEXT; */
return;
}
if (cfg_codepage == OEMCP)
{
cfg_clipboard_type = CF_OEMTEXT;
return;
}
/* Else determine a suitable locale the hard way. */
EnumSystemLocales (enum_locale_callback, LCID_INSTALLED);
}
int
ase_unary_relation_undefined(Lisp_Object l)
{
Fsignal(Qrelation_error, list1(l));
return 0;
}
static Lisp_Object
w32_dialog_show (struct frame *f, Lisp_Object title,
Lisp_Object header, char **error)
{
int i, nb_buttons = 0;
char dialog_name[6];
int menu_item_selection;
widget_value *wv, *first_wv = 0, *prev_wv = 0;
/* Number of elements seen so far, before boundary. */
int left_count = 0;
/* true means we've seen the boundary between left-hand elts and
right-hand. */
bool boundary_seen = false;
*error = NULL;
if (menu_items_n_panes > 1)
{
*error = "Multiple panes in dialog box";
return Qnil;
}
/* Create a tree of widget_value objects
representing the text label and buttons. */
{
Lisp_Object pane_name;
char *pane_string;
pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME);
pane_string = (NILP (pane_name)
? "" : SSDATA (pane_name));
prev_wv = make_widget_value ("message", pane_string, true, Qnil);
first_wv = prev_wv;
/* Loop over all panes and items, filling in the tree. */
i = MENU_ITEMS_PANE_LENGTH;
while (i < menu_items_used)
{
/* Create a new item within current pane. */
Lisp_Object item_name, enable, descrip, help;
item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
if (NILP (item_name))
{
free_menubar_widget_value_tree (first_wv);
*error = "Submenu in dialog items";
return Qnil;
}
if (EQ (item_name, Qquote))
{
/* This is the boundary between left-side elts
and right-side elts. Stop incrementing right_count. */
boundary_seen = true;
i++;
continue;
}
if (nb_buttons >= 9)
{
free_menubar_widget_value_tree (first_wv);
*error = "Too many dialog items";
return Qnil;
}
wv = make_widget_value (button_names[nb_buttons],
SSDATA (item_name),
!NILP (enable), Qnil);
prev_wv->next = wv;
if (!NILP (descrip))
wv->key = SSDATA (descrip);
wv->call_data = aref_addr (menu_items, i);
prev_wv = wv;
if (! boundary_seen)
left_count++;
nb_buttons++;
i += MENU_ITEMS_ITEM_LENGTH;
}
/* If the boundary was not specified,
by default put half on the left and half on the right. */
if (! boundary_seen)
left_count = nb_buttons - nb_buttons / 2;
wv = make_widget_value (dialog_name, NULL, false, Qnil);
/* Frame title: 'Q' = Question, 'I' = Information.
Can also have 'E' = Error if, one day, we want
a popup for errors. */
if (NILP (header))
dialog_name[0] = 'Q';
else
dialog_name[0] = 'I';
/* Dialog boxes use a really stupid name encoding
which specifies how many buttons to use
and how many buttons are on the right. */
dialog_name[1] = '0' + nb_buttons;
dialog_name[2] = 'B';
dialog_name[3] = 'R';
/* Number of buttons to put on the right. */
dialog_name[4] = '0' + nb_buttons - left_count;
dialog_name[5] = 0;
wv->contents = first_wv;
first_wv = wv;
}
/* Actually create the dialog. */
dialog_id = widget_id_tick++;
menu = lw_create_widget (first_wv->name, "dialog", dialog_id, first_wv,
f->output_data.w32->widget, true, 0,
dialog_selection_callback, 0);
lw_modify_all_widgets (dialog_id, first_wv->contents, TRUE);
/* Free the widget_value objects we used to specify the contents. */
free_menubar_widget_value_tree (first_wv);
/* No selection has been chosen yet. */
menu_item_selection = 0;
/* Display the menu. */
lw_pop_up_all_widgets (dialog_id);
/* Process events that apply to the menu. */
popup_get_selection ((XEvent *) 0, FRAME_DISPLAY_INFO (f), dialog_id);
lw_destroy_all_widgets (dialog_id);
/* Find the selected item, and its pane, to return
the proper value. */
if (menu_item_selection != 0)
{
i = 0;
while (i < menu_items_used)
{
Lisp_Object entry;
if (EQ (AREF (menu_items, i), Qt))
i += MENU_ITEMS_PANE_LENGTH;
else
{
entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
if (menu_item_selection == i)
return entry;
i += MENU_ITEMS_ITEM_LENGTH;
}
}
}
else
/* Make "Cancel" equivalent to C-g. */
Fsignal (Qquit, Qnil);
return Qnil;
}
Lisp_Object
w32_menu_show (struct frame *f, int x, int y, int menuflags,
Lisp_Object title, const char **error)
{
int i;
int menu_item_selection;
HMENU menu;
POINT pos;
widget_value *wv, *save_wv = 0, *first_wv = 0, *prev_wv = 0;
widget_value **submenu_stack
= (widget_value **) alloca (menu_items_used * sizeof (widget_value *));
Lisp_Object *subprefix_stack
= (Lisp_Object *) alloca (menu_items_used * word_size);
int submenu_depth = 0;
bool first_pane;
*error = NULL;
if (menu_items_n_panes == 0)
return Qnil;
if (menu_items_used <= MENU_ITEMS_PANE_LENGTH)
{
*error = "Empty menu";
return Qnil;
}
block_input ();
/* Create a tree of widget_value objects
representing the panes and their items. */
wv = make_widget_value ("menu", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
first_pane = true;
/* Loop over all panes and items, filling in the tree. */
i = 0;
while (i < menu_items_used)
{
if (EQ (AREF (menu_items, i), Qnil))
{
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
prev_wv = 0;
first_pane = false;
i++;
}
else if (EQ (AREF (menu_items, i), Qlambda))
{
prev_wv = save_wv;
save_wv = submenu_stack[--submenu_depth];
first_pane = false;
i++;
}
else if (EQ (AREF (menu_items, i), Qt)
&& submenu_depth != 0)
i += MENU_ITEMS_PANE_LENGTH;
/* Ignore a nil in the item list.
It's meaningful only for dialog boxes. */
else if (EQ (AREF (menu_items, i), Qquote))
i += 1;
else if (EQ (AREF (menu_items, i), Qt))
{
/* Create a new pane. */
Lisp_Object pane_name, prefix;
const char *pane_string;
pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME);
prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
if (STRINGP (pane_name))
{
if (unicode_append_menu)
pane_name = ENCODE_UTF_8 (pane_name);
else if (STRING_MULTIBYTE (pane_name))
pane_name = ENCODE_SYSTEM (pane_name);
ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
}
pane_string = (NILP (pane_name)
? "" : SSDATA (pane_name));
/* If there is just one top-level pane, put all its items directly
under the top-level menu. */
if (menu_items_n_panes == 1)
pane_string = "";
/* If the pane has a meaningful name,
make the pane a top-level menu item
with its items as a submenu beneath it. */
if (!(menuflags & MENU_KEYMAPS) && strcmp (pane_string, ""))
{
wv = make_widget_value (pane_string, NULL, true, Qnil);
if (save_wv)
save_wv->next = wv;
else
first_wv->contents = wv;
if ((menuflags & MENU_KEYMAPS) && !NILP (prefix))
wv->name++;
wv->button_type = BUTTON_TYPE_NONE;
save_wv = wv;
prev_wv = 0;
}
else if (first_pane)
{
save_wv = wv;
prev_wv = 0;
}
first_pane = false;
i += MENU_ITEMS_PANE_LENGTH;
}
else
{
/* Create a new item within current pane. */
Lisp_Object item_name, enable, descrip, def, type, selected, help;
item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION);
type = AREF (menu_items, i + MENU_ITEMS_ITEM_TYPE);
selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED);
help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
if (STRINGP (item_name))
{
if (unicode_append_menu)
item_name = ENCODE_UTF_8 (item_name);
else if (STRING_MULTIBYTE (item_name))
item_name = ENCODE_SYSTEM (item_name);
ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
}
if (STRINGP (descrip) && STRING_MULTIBYTE (descrip))
{
descrip = ENCODE_SYSTEM (descrip);
ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
}
wv = make_widget_value (SSDATA (item_name), NULL, !NILP (enable),
STRINGP (help) ? help : Qnil);
if (prev_wv)
prev_wv->next = wv;
else
save_wv->contents = wv;
if (!NILP (descrip))
wv->key = SSDATA (descrip);
/* Use the contents index as call_data, since we are
restricted to 16-bits. */
wv->call_data = !NILP (def) ? (void *) (UINT_PTR) i : 0;
if (NILP (type))
wv->button_type = BUTTON_TYPE_NONE;
else if (EQ (type, QCtoggle))
wv->button_type = BUTTON_TYPE_TOGGLE;
else if (EQ (type, QCradio))
wv->button_type = BUTTON_TYPE_RADIO;
else
emacs_abort ();
wv->selected = !NILP (selected);
prev_wv = wv;
i += MENU_ITEMS_ITEM_LENGTH;
}
}
/* Deal with the title, if it is non-nil. */
if (!NILP (title))
{
widget_value *wv_title;
widget_value *wv_sep = make_widget_value ("--", NULL, false, Qnil);
/* Maybe replace this separator with a bitmap or owner-draw item
so that it looks better. Having two separators looks odd. */
wv_sep->next = first_wv->contents;
if (unicode_append_menu)
title = ENCODE_UTF_8 (title);
else if (STRING_MULTIBYTE (title))
title = ENCODE_SYSTEM (title);
wv_title = make_widget_value (SSDATA (title), NULL, true, Qnil);
wv_title->title = TRUE;
wv_title->button_type = BUTTON_TYPE_NONE;
wv_title->next = wv_sep;
first_wv->contents = wv_title;
}
/* No selection has been chosen yet. */
menu_item_selection = 0;
/* Actually create the menu. */
current_popup_menu = menu = CreatePopupMenu ();
fill_in_menu (menu, first_wv->contents);
/* Adjust coordinates to be root-window-relative. */
pos.x = x;
pos.y = y;
ClientToScreen (FRAME_W32_WINDOW (f), &pos);
/* Display the menu. */
menu_item_selection = SendMessage (FRAME_W32_WINDOW (f),
WM_EMACS_TRACKPOPUPMENU,
(WPARAM)menu, (LPARAM)&pos);
/* Clean up extraneous mouse events which might have been generated
during the call. */
discard_mouse_events ();
FRAME_DISPLAY_INFO (f)->grabbed = 0;
/* Free the widget_value objects we used to specify the contents. */
free_menubar_widget_value_tree (first_wv);
DestroyMenu (menu);
/* Free the owner-drawn and help-echo menu strings. */
w32_free_menu_strings (FRAME_W32_WINDOW (f));
f->output_data.w32->menubar_active = 0;
/* Find the selected item, and its pane, to return
the proper value. */
if (menu_item_selection != 0)
{
Lisp_Object prefix, entry;
prefix = entry = Qnil;
i = 0;
while (i < menu_items_used)
{
if (EQ (AREF (menu_items, i), Qnil))
{
subprefix_stack[submenu_depth++] = prefix;
prefix = entry;
i++;
}
else if (EQ (AREF (menu_items, i), Qlambda))
{
prefix = subprefix_stack[--submenu_depth];
i++;
}
else if (EQ (AREF (menu_items, i), Qt))
{
prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
i += MENU_ITEMS_PANE_LENGTH;
}
/* Ignore a nil in the item list.
It's meaningful only for dialog boxes. */
else if (EQ (AREF (menu_items, i), Qquote))
i += 1;
else
{
entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
if (menu_item_selection == i)
{
if (menuflags & MENU_KEYMAPS)
{
int j;
entry = Fcons (entry, Qnil);
if (!NILP (prefix))
entry = Fcons (prefix, entry);
for (j = submenu_depth - 1; j >= 0; j--)
if (!NILP (subprefix_stack[j]))
entry = Fcons (subprefix_stack[j], entry);
}
unblock_input ();
return entry;
}
i += MENU_ITEMS_ITEM_LENGTH;
}
}
}
else if (!(menuflags & MENU_FOR_CLICK))
{
unblock_input ();
/* Make "Cancel" equivalent to C-g. */
Fsignal (Qquit, Qnil);
}
unblock_input ();
return Qnil;
}
static Lisp_Object
simple_dialog_show (struct frame *f, Lisp_Object contents, Lisp_Object header)
{
int answer;
UINT type;
Lisp_Object lispy_answer = Qnil, temp = XCAR (contents);
type = MB_YESNO;
/* Since we only handle Yes/No dialogs, and we already checked
is_simple_dialog, we don't need to worry about checking contents
to see what type of dialog to use. */
/* Use Unicode if possible, so any language can be displayed. */
if (unicode_message_box)
{
WCHAR *text;
const WCHAR *title;
USE_SAFE_ALLOCA;
if (STRINGP (temp))
{
char *utf8_text = SSDATA (ENCODE_UTF_8 (temp));
/* Be pessimistic about the number of characters needed.
Remember characters outside the BMP will take more than
one utf16 word, so we cannot simply use the character
length of temp. */
int utf8_len = strlen (utf8_text);
text = SAFE_ALLOCA ((utf8_len + 1) * sizeof (WCHAR));
utf8to16 ((unsigned char *)utf8_text, utf8_len, text);
}
else
{
text = (WCHAR *)L"";
}
if (NILP (header))
{
title = L"Question";
type |= MB_ICONQUESTION;
}
else
{
title = L"Information";
type |= MB_ICONINFORMATION;
}
answer = unicode_message_box (FRAME_W32_WINDOW (f), text, title, type);
SAFE_FREE ();
}
else
{
const char *text, *title;
/* Fall back on ANSI message box, but at least use system
encoding so questions representable by the system codepage
are encoded properly. */
if (STRINGP (temp))
text = SSDATA (ENCODE_SYSTEM (temp));
else
text = "";
if (NILP (header))
{
title = "Question";
type |= MB_ICONQUESTION;
}
else
{
title = "Information";
type |= MB_ICONINFORMATION;
}
answer = MessageBox (FRAME_W32_WINDOW (f), text, title, type);
}
if (answer == IDYES)
lispy_answer = build_string ("Yes");
else if (answer == IDNO)
lispy_answer = build_string ("No");
else
Fsignal (Qquit, Qnil);
for (temp = XCDR (contents); CONSP (temp); temp = XCDR (temp))
{
Lisp_Object item, name, value;
item = XCAR (temp);
if (CONSP (item))
{
name = XCAR (item);
value = XCDR (item);
}
else
{
name = item;
value = Qnil;
}
if (!NILP (Fstring_equal (name, lispy_answer)))
{
return value;
}
}
Fsignal (Qquit, Qnil);
return Qnil;
}
static char *
rep_ffi_demarshal (unsigned int type_id, char *ptr, repv *value)
{
rep_ffi_type *type = ffi_types[type_id];
switch (type->subtype)
{
DEFSTRING (err, "unknown ffi type id");
case rep_FFI_PRIMITIVE:
switch (type->type->type)
{
case FFI_TYPE_VOID:
*value = rep_undefined_value;
return ptr;
case FFI_TYPE_INT:
*value = rep_make_long_int (*(int *)ptr);
return ptr + sizeof (int);
case FFI_TYPE_FLOAT:
*value = rep_make_float (*(float *)ptr, rep_TRUE);
return ptr + sizeof (float);
case FFI_TYPE_DOUBLE:
*value = rep_make_float (*(double *)ptr, rep_TRUE);
return ptr + sizeof (double);
#if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE
case FFI_TYPE_LONGDOUBLE:
*value = rep_make_float (*(long double *)ptr, rep_TRUE);
return ptr + sizeof (long double);
#endif
case FFI_TYPE_UINT8:
*value = rep_MAKE_INT (*(uint8_t *)ptr);
return ptr + sizeof (uint8_t);
case FFI_TYPE_SINT8:
*value = rep_MAKE_INT (*(int8_t *)ptr);
return ptr + sizeof (int8_t);
case FFI_TYPE_UINT16:
*value = rep_MAKE_INT (*(uint16_t *)ptr);
return ptr + sizeof (uint16_t);
case FFI_TYPE_SINT16:
*value = rep_MAKE_INT (*(int16_t *)ptr);
return ptr + sizeof (int16_t);
case FFI_TYPE_UINT32:
*value = rep_make_long_int (*(uint32_t *)ptr);
return ptr + sizeof (uint32_t);
case FFI_TYPE_SINT32:
*value = rep_make_long_int (*(int32_t *)ptr);
return ptr + sizeof (int32_t);
case FFI_TYPE_UINT64:
*value = rep_make_longlong_int (*(uint64_t *)ptr);
return ptr + sizeof (uint64_t);
case FFI_TYPE_SINT64:
*value = rep_make_longlong_int (*(int64_t *)ptr);
return ptr + sizeof (int64_t);
case FFI_TYPE_POINTER:
*value = rep_make_pointer (*(void **)ptr);
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_n_roots gc_value;
int i;
*value = rep_make_vector (s->n_elements);
rep_PUSHGCN (gc_value, value, 1);
for (i = 0; i < s->n_elements; i++)
{
ptr = rep_ffi_demarshal (s->element_ids[i], ptr,
&rep_VECTI (*value, i));
if (ptr == NULL) {
rep_POPGCN;
return NULL;
}
}
rep_POPGCN;
return ptr;
}
case rep_FFI_ALIAS: {
rep_ffi_alias *s = (rep_ffi_alias *) type;
ptr = rep_ffi_marshal (s->base, *value, ptr);
if (s->conv_in != rep_NULL) {
*value = rep_call_lisp1 (s->conv_out, *value);
if (*value == rep_NULL)
return NULL;
}
return ptr;
}
default:
Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id)));
return NULL;
}
}
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;
}
}
Lisp_Object
signal_failure (Lisp_Object arg)
{
Fsignal (Qsearch_failed, Fcons (arg, Qnil));
return Qnil;
}
