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; }