2015-11-19 08:14:00 -08:00
|
|
|
/* Test GNU Emacs modules.
|
|
|
|
|
2017-01-01 03:14:01 +00:00
|
|
|
Copyright 2015-2017 Free Software Foundation, Inc.
|
2015-11-19 08:14:00 -08:00
|
|
|
|
|
|
|
This file is part of GNU Emacs.
|
|
|
|
|
|
|
|
GNU Emacs is free software: you can redistribute it and/or modify
|
|
|
|
it under the terms of the GNU General Public License as published by
|
2016-03-10 07:34:52 -08:00
|
|
|
the Free Software Foundation, either version 3 of the License, or (at
|
|
|
|
your option) any later version.
|
2015-11-19 08:14:00 -08:00
|
|
|
|
|
|
|
GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
GNU General Public License for more details.
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
|
|
along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
|
|
|
|
|
2015-11-16 01:00:25 +01:00
|
|
|
#include <assert.h>
|
|
|
|
#include <stdio.h>
|
2015-11-20 13:37:25 +02:00
|
|
|
#include <stdlib.h>
|
2015-11-19 13:50:23 -08:00
|
|
|
#include <emacs-module.h>
|
2015-11-16 01:00:25 +01:00
|
|
|
|
|
|
|
int plugin_is_GPL_compatible;
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Always return symbol 't'. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_return_t (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
return env->intern (env, "t");
|
|
|
|
}
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Expose simple sum function. */
|
2015-11-19 14:03:29 -08:00
|
|
|
static intmax_t
|
|
|
|
sum (intmax_t a, intmax_t b)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
return a + b;
|
|
|
|
}
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_sum (emacs_env *env, ptrdiff_t nargs, emacs_value args[], void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
2015-11-24 21:08:22 +02:00
|
|
|
assert (nargs == 2);
|
|
|
|
|
2015-11-19 14:03:29 -08:00
|
|
|
intmax_t a = env->extract_integer (env, args[0]);
|
|
|
|
intmax_t b = env->extract_integer (env, args[1]);
|
2015-11-16 01:00:25 +01:00
|
|
|
|
2015-11-19 14:03:29 -08:00
|
|
|
intmax_t r = sum (a, b);
|
2015-11-16 01:00:25 +01:00
|
|
|
|
|
|
|
return env->make_integer (env, r);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Signal '(error 56). */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
|
2015-11-19 11:31:45 -08:00
|
|
|
env->non_local_exit_signal (env, env->intern (env, "error"),
|
|
|
|
env->make_integer (env, 56));
|
2015-11-30 14:34:42 -05:00
|
|
|
return env->intern (env, "nil");
|
2015-11-16 01:00:25 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Throw '(tag 65). */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
|
2015-11-19 11:31:45 -08:00
|
|
|
env->non_local_exit_throw (env, env->intern (env, "tag"),
|
|
|
|
env->make_integer (env, 65));
|
2015-11-30 14:34:42 -05:00
|
|
|
return env->intern (env, "nil");
|
2015-11-16 01:00:25 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Call argument function, catch all non-local exists and return
|
|
|
|
either normal result or a list describing the non-local exit. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_non_local_exit_funcall (emacs_env *env, ptrdiff_t nargs,
|
|
|
|
emacs_value args[], void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
assert (nargs == 1);
|
Omit ‘const’ on locals
Remove ‘const’ qualifier from locals that were newly added.
We don’t normally bother declaring locals with ‘const’ even
though they are not modified, for the same reason we don’t
bother declaring them with ‘register’ even though their
addresses are not taken; the advantage in compile-time
checking isn’t worth the loss of readability.
* modules/mod-test/mod-test.c (Fmod_test_non_local_exit_funcall)
(Fmod_test_vector_fill, Fmod_test_vector_eq):
* src/emacs-module.c (MODULE_SETJMP_1)
(module_make_global_ref, module_free_global_ref)
(module_non_local_exit_get, module_make_function)
(module_extract_integer, module_extract_float)
(module_get_user_ptr, module_set_user_ptr)
(module_get_user_finalizer, module_set_user_finalizer)
(module_vec_get, Fmodule_call)
(module_non_local_exit_signal_1)
(module_non_local_exit_throw_1, lisp_to_value)
(finalize_storage, allocate_emacs_value, mark_modules)
(module_handle_signal, module_handle_throw)
(module_format_fun_env):
* src/eval.c (push_handler, push_handler_nosignal)
(init_handler):
* src/lread.c (suffix_p):
Omit unnecessary ‘const’.
2015-11-19 14:24:50 -08:00
|
|
|
emacs_value result = env->funcall (env, args[0], 0, NULL);
|
2015-11-16 01:00:25 +01:00
|
|
|
emacs_value non_local_exit_symbol, non_local_exit_data;
|
2015-11-19 11:31:45 -08:00
|
|
|
enum emacs_funcall_exit code
|
|
|
|
= env->non_local_exit_get (env, &non_local_exit_symbol,
|
|
|
|
&non_local_exit_data);
|
2015-11-16 01:00:25 +01:00
|
|
|
switch (code)
|
|
|
|
{
|
|
|
|
case emacs_funcall_exit_return:
|
|
|
|
return result;
|
|
|
|
case emacs_funcall_exit_signal:
|
|
|
|
{
|
|
|
|
env->non_local_exit_clear (env);
|
Omit ‘const’ on locals
Remove ‘const’ qualifier from locals that were newly added.
We don’t normally bother declaring locals with ‘const’ even
though they are not modified, for the same reason we don’t
bother declaring them with ‘register’ even though their
addresses are not taken; the advantage in compile-time
checking isn’t worth the loss of readability.
* modules/mod-test/mod-test.c (Fmod_test_non_local_exit_funcall)
(Fmod_test_vector_fill, Fmod_test_vector_eq):
* src/emacs-module.c (MODULE_SETJMP_1)
(module_make_global_ref, module_free_global_ref)
(module_non_local_exit_get, module_make_function)
(module_extract_integer, module_extract_float)
(module_get_user_ptr, module_set_user_ptr)
(module_get_user_finalizer, module_set_user_finalizer)
(module_vec_get, Fmodule_call)
(module_non_local_exit_signal_1)
(module_non_local_exit_throw_1, lisp_to_value)
(finalize_storage, allocate_emacs_value, mark_modules)
(module_handle_signal, module_handle_throw)
(module_format_fun_env):
* src/eval.c (push_handler, push_handler_nosignal)
(init_handler):
* src/lread.c (suffix_p):
Omit unnecessary ‘const’.
2015-11-19 14:24:50 -08:00
|
|
|
emacs_value Flist = env->intern (env, "list");
|
2015-11-19 11:31:45 -08:00
|
|
|
emacs_value list_args[] = {env->intern (env, "signal"),
|
|
|
|
non_local_exit_symbol, non_local_exit_data};
|
2015-11-16 01:00:25 +01:00
|
|
|
return env->funcall (env, Flist, 3, list_args);
|
|
|
|
}
|
|
|
|
case emacs_funcall_exit_throw:
|
|
|
|
{
|
|
|
|
env->non_local_exit_clear (env);
|
Omit ‘const’ on locals
Remove ‘const’ qualifier from locals that were newly added.
We don’t normally bother declaring locals with ‘const’ even
though they are not modified, for the same reason we don’t
bother declaring them with ‘register’ even though their
addresses are not taken; the advantage in compile-time
checking isn’t worth the loss of readability.
* modules/mod-test/mod-test.c (Fmod_test_non_local_exit_funcall)
(Fmod_test_vector_fill, Fmod_test_vector_eq):
* src/emacs-module.c (MODULE_SETJMP_1)
(module_make_global_ref, module_free_global_ref)
(module_non_local_exit_get, module_make_function)
(module_extract_integer, module_extract_float)
(module_get_user_ptr, module_set_user_ptr)
(module_get_user_finalizer, module_set_user_finalizer)
(module_vec_get, Fmodule_call)
(module_non_local_exit_signal_1)
(module_non_local_exit_throw_1, lisp_to_value)
(finalize_storage, allocate_emacs_value, mark_modules)
(module_handle_signal, module_handle_throw)
(module_format_fun_env):
* src/eval.c (push_handler, push_handler_nosignal)
(init_handler):
* src/lread.c (suffix_p):
Omit unnecessary ‘const’.
2015-11-19 14:24:50 -08:00
|
|
|
emacs_value Flist = env->intern (env, "list");
|
2015-11-19 11:31:45 -08:00
|
|
|
emacs_value list_args[] = {env->intern (env, "throw"),
|
|
|
|
non_local_exit_symbol, non_local_exit_data};
|
2015-11-16 01:00:25 +01:00
|
|
|
return env->funcall (env, Flist, 3, list_args);
|
|
|
|
}
|
|
|
|
}
|
2015-11-19 11:31:45 -08:00
|
|
|
|
|
|
|
/* Never reached. */
|
2015-11-16 01:00:25 +01:00
|
|
|
return env->intern (env, "nil");;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-29 21:50:59 -08:00
|
|
|
/* Return a global reference. */
|
2015-11-19 11:31:45 -08:00
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_globref_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
2015-11-19 11:31:45 -08:00
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Make a big string and make it global. */
|
|
|
|
char str[26 * 100];
|
2015-11-19 15:01:26 -08:00
|
|
|
for (int i = 0; i < sizeof str; i++)
|
2015-11-19 11:31:45 -08:00
|
|
|
str[i] = 'a' + (i % 26);
|
2015-11-16 01:00:25 +01:00
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* We don't need to null-terminate str. */
|
|
|
|
emacs_value lisp_str = env->make_string (env, str, sizeof str);
|
2015-11-16 01:00:25 +01:00
|
|
|
return env->make_global_ref (env, lisp_str);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Return a copy of the argument string where every 'a' is replaced
|
|
|
|
with 'b'. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_string_a_to_b (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
2015-11-19 11:31:45 -08:00
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
emacs_value lisp_str = args[0];
|
2015-11-19 15:01:26 -08:00
|
|
|
ptrdiff_t size = 0;
|
2015-11-16 01:00:25 +01:00
|
|
|
char * buf = NULL;
|
|
|
|
|
|
|
|
env->copy_string_contents (env, lisp_str, buf, &size);
|
|
|
|
buf = malloc (size);
|
|
|
|
env->copy_string_contents (env, lisp_str, buf, &size);
|
|
|
|
|
2015-11-19 15:01:26 -08:00
|
|
|
for (ptrdiff_t i = 0; i + 1 < size; i++)
|
2015-11-16 01:00:25 +01:00
|
|
|
if (buf[i] == 'a')
|
|
|
|
buf[i] = 'b';
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
return env->make_string (env, buf, size - 1);
|
2015-11-16 01:00:25 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Embedded pointers in lisp objects. */
|
2015-11-16 01:00:25 +01:00
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* C struct (pointer to) that will be embedded. */
|
2015-11-16 01:00:25 +01:00
|
|
|
struct super_struct
|
|
|
|
{
|
|
|
|
int amazing_int;
|
|
|
|
char large_unused_buffer[512];
|
|
|
|
};
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Return a new user-pointer to a super_struct, with amazing_int set
|
|
|
|
to the passed parameter. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_userptr_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
2015-11-19 11:31:45 -08:00
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
2015-11-19 11:31:45 -08:00
|
|
|
struct super_struct *p = calloc (1, sizeof *p);
|
2015-11-16 01:00:25 +01:00
|
|
|
p->amazing_int = env->extract_integer (env, args[0]);
|
2015-11-19 11:31:45 -08:00
|
|
|
return env->make_user_ptr (env, free, p);
|
2015-11-16 01:00:25 +01:00
|
|
|
}
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Return the amazing_int of a passed 'user-pointer to a super_struct'. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_userptr_get (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
struct super_struct *p = env->get_user_ptr (env, args[0]);
|
|
|
|
return env->make_integer (env, p->amazing_int);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Fill vector in args[0] with value in args[1]. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_vector_fill (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
emacs_value vec = args[0];
|
|
|
|
emacs_value val = args[1];
|
2015-11-19 15:01:26 -08:00
|
|
|
ptrdiff_t size = env->vec_size (env, vec);
|
|
|
|
for (ptrdiff_t i = 0; i < size; i++)
|
2015-11-16 01:00:25 +01:00
|
|
|
env->vec_set (env, vec, i, val);
|
|
|
|
return env->intern (env, "t");
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Return whether all elements of vector in args[0] are 'eq' to value
|
|
|
|
in args[1]. */
|
|
|
|
static emacs_value
|
2015-11-20 12:17:55 -08:00
|
|
|
Fmod_test_vector_eq (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
|
|
|
|
void *data)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
emacs_value vec = args[0];
|
|
|
|
emacs_value val = args[1];
|
2015-11-19 15:01:26 -08:00
|
|
|
ptrdiff_t size = env->vec_size (env, vec);
|
|
|
|
for (ptrdiff_t i = 0; i < size; i++)
|
2015-11-16 01:00:25 +01:00
|
|
|
if (!env->eq (env, env->vec_get (env, vec, i), val))
|
|
|
|
return env->intern (env, "nil");
|
|
|
|
return env->intern (env, "t");
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Lisp utilities for easier readability (simple wrappers). */
|
2015-11-16 01:00:25 +01:00
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Provide FEATURE to Emacs. */
|
|
|
|
static void
|
|
|
|
provide (emacs_env *env, const char *feature)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
emacs_value Qfeat = env->intern (env, feature);
|
|
|
|
emacs_value Qprovide = env->intern (env, "provide");
|
|
|
|
emacs_value args[] = { Qfeat };
|
|
|
|
|
|
|
|
env->funcall (env, Qprovide, 1, args);
|
|
|
|
}
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Bind NAME to FUN. */
|
|
|
|
static void
|
|
|
|
bind_function (emacs_env *env, const char *name, emacs_value Sfun)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
emacs_value Qfset = env->intern (env, "fset");
|
|
|
|
emacs_value Qsym = env->intern (env, name);
|
|
|
|
emacs_value args[] = { Qsym, Sfun };
|
|
|
|
|
|
|
|
env->funcall (env, Qfset, 2, args);
|
|
|
|
}
|
|
|
|
|
2015-11-19 11:31:45 -08:00
|
|
|
/* Module init function. */
|
|
|
|
int
|
|
|
|
emacs_module_init (struct emacs_runtime *ert)
|
2015-11-16 01:00:25 +01:00
|
|
|
{
|
|
|
|
emacs_env *env = ert->get_environment (ert);
|
|
|
|
|
|
|
|
#define DEFUN(lsym, csym, amin, amax, doc, data) \
|
2015-11-19 11:31:45 -08:00
|
|
|
bind_function (env, lsym, \
|
|
|
|
env->make_function (env, amin, amax, csym, doc, data))
|
2015-11-16 01:00:25 +01:00
|
|
|
|
|
|
|
DEFUN ("mod-test-return-t", Fmod_test_return_t, 1, 1, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B", NULL);
|
|
|
|
DEFUN ("mod-test-signal", Fmod_test_signal, 0, 0, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL);
|
2015-11-19 11:31:45 -08:00
|
|
|
DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall,
|
|
|
|
1, 1, NULL, NULL);
|
2015-11-16 01:00:25 +01:00
|
|
|
DEFUN ("mod-test-globref-make", Fmod_test_globref_make, 0, 0, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-string-a-to-b", Fmod_test_string_a_to_b, 1, 1, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-userptr-make", Fmod_test_userptr_make, 1, 1, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-userptr-get", Fmod_test_userptr_get, 1, 1, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-vector-fill", Fmod_test_vector_fill, 2, 2, NULL, NULL);
|
|
|
|
DEFUN ("mod-test-vector-eq", Fmod_test_vector_eq, 2, 2, NULL, NULL);
|
|
|
|
|
|
|
|
#undef DEFUN
|
|
|
|
|
|
|
|
provide (env, "mod-test");
|
|
|
|
return 0;
|
|
|
|
}
|