static emacs_value module_make_global_ref (emacs_env *env, emacs_value ref) { MODULE_FUNCTION_BEGIN (module_nil); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); Lisp_Object new_obj = value_to_lisp (ref); EMACS_UINT hashcode; ptrdiff_t i = hash_lookup (h, new_obj, &hashcode); if (i >= 0) { Lisp_Object value = HASH_VALUE (h, i); EMACS_INT refcount = XFASTINT (value) + 1; if (MOST_POSITIVE_FIXNUM < refcount) xsignal0 (Qoverflow_error); value = make_natnum (refcount); set_hash_value_slot (h, i, value); } else { hash_put (h, new_obj, make_natnum (1), hashcode); } return lisp_to_value (new_obj); }
static bool module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, ptrdiff_t *length) { MODULE_FUNCTION_BEGIN (false); Lisp_Object lisp_str = value_to_lisp (value); CHECK_STRING (lisp_str); Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str); ptrdiff_t raw_size = SBYTES (lisp_str_utf8); ptrdiff_t required_buf_size = raw_size + 1; eassert (length != NULL); if (buffer == NULL) { *length = required_buf_size; return true; } eassert (*length >= 0); if (*length < required_buf_size) { *length = required_buf_size; xsignal0 (Qargs_out_of_range); } *length = required_buf_size; memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1); return true; }
static void module_free_global_ref (emacs_env *env, emacs_value ref) { /* TODO: This probably never signals. */ /* FIXME: Wait a minute. Shouldn't this function report an error if the hash lookup fails? */ MODULE_FUNCTION_BEGIN (); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); Lisp_Object obj = value_to_lisp (ref); EMACS_UINT hashcode; ptrdiff_t i = hash_lookup (h, obj, &hashcode); if (i >= 0) { Lisp_Object value = HASH_VALUE (h, i); EMACS_INT refcount = XFASTINT (value) - 1; if (refcount > 0) { value = make_natnum (refcount); set_hash_value_slot (h, i, value); } else hash_remove_from_table (h, value); } }
static emacs_value module_make_string (emacs_env *env, const char *str, ptrdiff_t length) { MODULE_FUNCTION_BEGIN (module_nil); Lisp_Object lstr = make_unibyte_string (str, length); return lisp_to_value (code_convert_string_norecord (lstr, Qutf_8, false)); }
static emacs_finalizer_function module_get_user_finalizer (emacs_env *env, emacs_value uptr) { MODULE_FUNCTION_BEGIN (NULL); Lisp_Object lisp = value_to_lisp (uptr); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->finalizer; }
static emacs_value module_make_integer (emacs_env *env, intmax_t n) { MODULE_FUNCTION_BEGIN (module_nil); if (FIXNUM_OVERFLOW_P (n)) xsignal0 (Qoverflow_error); return lisp_to_value (make_number (n)); }
static double module_extract_float (emacs_env *env, emacs_value f) { MODULE_FUNCTION_BEGIN (0); Lisp_Object lisp = value_to_lisp (f); CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp); return XFLOAT_DATA (lisp); }
static void * module_get_user_ptr (emacs_env *env, emacs_value uptr) { MODULE_FUNCTION_BEGIN (NULL); Lisp_Object lisp = value_to_lisp (uptr); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->p; }
static intmax_t module_extract_integer (emacs_env *env, emacs_value n) { MODULE_FUNCTION_BEGIN (0); Lisp_Object l = value_to_lisp (n); CHECK_NUMBER (l); return XINT (l); }
static ptrdiff_t module_vec_size (emacs_env *env, emacs_value vec) { /* FIXME: Return a sentinel value (e.g., -1) on error. */ MODULE_FUNCTION_BEGIN (0); Lisp_Object lvec = value_to_lisp (vec); CHECK_VECTOR (lvec); return ASIZE (lvec); }
static void module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lisp = value_to_lisp (uptr); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->p = ptr; }
static emacs_value module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) { MODULE_FUNCTION_BEGIN (module_nil); Lisp_Object lvec = value_to_lisp (vec); CHECK_VECTOR (lvec); CHECK_RANGED_INTEGER (make_number (i), 0, ASIZE (lvec) - 1); return lisp_to_value (AREF (lvec, i)); }
static void module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lvec = value_to_lisp (vec); CHECK_VECTOR (lvec); CHECK_RANGED_INTEGER (make_number (i), 0, ASIZE (lvec) - 1); ASET (lvec, i, value_to_lisp (val)); }
static emacs_value module_make_integer (emacs_env *env, intmax_t n) { MODULE_FUNCTION_BEGIN (module_nil); if (! (MOST_NEGATIVE_FIXNUM <= n && n <= MOST_POSITIVE_FIXNUM)) { module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return module_nil; } return lisp_to_value (make_number (n)); }
static void module_set_user_finalizer (emacs_env *env, emacs_value uptr, emacs_finalizer_function fin) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lisp = value_to_lisp (uptr); if (! USER_PTRP (lisp)) module_wrong_type (env, Quser_ptr, lisp); XUSER_PTR (lisp)->finalizer = fin; }
static intmax_t module_extract_integer (emacs_env *env, emacs_value n) { MODULE_FUNCTION_BEGIN (0); Lisp_Object l = value_to_lisp (n); if (! INTEGERP (l)) { module_wrong_type (env, Qintegerp, l); return 0; } return XINT (l); }
static double module_extract_float (emacs_env *env, emacs_value f) { MODULE_FUNCTION_BEGIN (0); Lisp_Object lisp = value_to_lisp (f); if (! FLOATP (lisp)) { module_wrong_type (env, Qfloatp, lisp); return 0; } return XFLOAT_DATA (lisp); }
static emacs_finalizer_function module_get_user_finalizer (emacs_env *env, emacs_value uptr) { MODULE_FUNCTION_BEGIN (NULL); Lisp_Object lisp = value_to_lisp (uptr); if (! USER_PTRP (lisp)) { module_wrong_type (env, Quser_ptr, lisp); return NULL; } return XUSER_PTR (lisp)->finalizer; }
static emacs_value module_make_string (emacs_env *env, const char *str, ptrdiff_t length) { MODULE_FUNCTION_BEGIN (module_nil); if (length > STRING_BYTES_BOUND) { module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return module_nil; } Lisp_Object lstr = make_unibyte_string (str, length); return lisp_to_value (code_convert_string_norecord (lstr, Qutf_8, false)); }
static ptrdiff_t module_vec_size (emacs_env *env, emacs_value vec) { /* FIXME: Return a sentinel value (e.g., -1) on error. */ MODULE_FUNCTION_BEGIN (0); Lisp_Object lvec = value_to_lisp (vec); if (! VECTORP (lvec)) { module_wrong_type (env, Qvectorp, lvec); return 0; } return ASIZE (lvec); }
static void module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); check_main_thread (); if (module_non_local_exit_check (env) != emacs_funcall_exit_return) return; Lisp_Object lisp = value_to_lisp (uptr); if (! USER_PTRP (lisp)) module_wrong_type (env, Quser_ptr, lisp); XUSER_PTR (lisp)->p = ptr; }
static emacs_value module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, emacs_value args[]) { MODULE_FUNCTION_BEGIN (module_nil); /* Make a new Lisp_Object array starting with the function as the first arg, because that's what Ffuncall takes. */ Lisp_Object *newargs; USE_SAFE_ALLOCA; SAFE_ALLOCA_LISP (newargs, nargs + 1); newargs[0] = value_to_lisp (fun); for (ptrdiff_t i = 0; i < nargs; i++) newargs[1 + i] = value_to_lisp (args[i]); emacs_value result = lisp_to_value (Ffuncall (nargs + 1, newargs)); SAFE_FREE (); return result; }
static bool module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, ptrdiff_t *length) { MODULE_FUNCTION_BEGIN (false); Lisp_Object lisp_str = value_to_lisp (value); if (! STRINGP (lisp_str)) { module_wrong_type (env, Qstringp, lisp_str); return false; } Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str); ptrdiff_t raw_size = SBYTES (lisp_str_utf8); if (raw_size == PTRDIFF_MAX) { module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return false; } ptrdiff_t required_buf_size = raw_size + 1; eassert (length != NULL); if (buffer == NULL) { *length = required_buf_size; return true; } eassert (*length >= 0); if (*length < required_buf_size) { *length = required_buf_size; module_non_local_exit_signal_1 (env, Qargs_out_of_range, Qnil); return false; } *length = required_buf_size; memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1); return true; }
static emacs_value module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) { MODULE_FUNCTION_BEGIN (module_nil); Lisp_Object lvec = value_to_lisp (vec); if (! VECTORP (lvec)) { module_wrong_type (env, Qvectorp, lvec); return module_nil; } if (! (0 <= i && i < ASIZE (lvec))) { if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) module_args_out_of_range (env, lvec, make_number (i)); else module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return module_nil; } return lisp_to_value (AREF (lvec, i)); }
static void module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lvec = value_to_lisp (vec); if (! VECTORP (lvec)) { module_wrong_type (env, Qvectorp, lvec); return; } if (! (0 <= i && i < ASIZE (lvec))) { if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) module_args_out_of_range (env, lvec, make_number (i)); else module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return; } ASET (lvec, i, value_to_lisp (val)); }
static emacs_value module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, emacs_subr subr, const char *documentation, void *data) { MODULE_FUNCTION_BEGIN (module_nil); if (! (0 <= min_arity && (max_arity < 0 ? max_arity == emacs_variadic_function : min_arity <= max_arity))) xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity)); /* FIXME: This should be freed when envobj is GC'd. */ struct module_fun_env *envptr = xmalloc (sizeof *envptr); envptr->min_arity = min_arity; envptr->max_arity = max_arity; envptr->subr = subr; envptr->data = data; Lisp_Object envobj = make_save_ptr (envptr); Lisp_Object doc = (documentation ? code_convert_string_norecord (build_unibyte_string (documentation), Qutf_8, false) : Qnil); /* FIXME: Use a bytecompiled object, or even better a subr. */ Lisp_Object ret = list4 (Qlambda, list2 (Qand_rest, Qargs), doc, list4 (Qapply, list2 (Qfunction, Qinternal__module_call), envobj, Qargs)); return lisp_to_value (ret); }
static emacs_value module_intern (emacs_env *env, const char *name) { MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (intern (name)); }
static emacs_value module_type_of (emacs_env *env, emacs_value value) { MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (Ftype_of (value_to_lisp (value))); }
static emacs_value module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) { MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (make_user_ptr (fin, ptr)); }
static emacs_value module_make_float (emacs_env *env, double d) { MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (make_float (d)); }