Commit a3e96940 authored by Philipp Stephani's avatar Philipp Stephani Committed by Philipp

Introduce new misc type for module function

This resolves a couple of FIXMEs in emacs-module.c.

* src/lisp.h (MODULE_FUNCTIONP, XMODULE_FUNCTION): New functions.

* src/alloc.c (make_module_function): New function.
(mark_object): GC support.

* src/data.c (Ftype_of, syms_of_data): Handle module function type.

* src/print.c (print_object): Print support for new type.

* src/emacs-module.c (module_make_function, Finternal_module_call):
Use new module function type, remove FIXMEs.
(module_format_fun_env): Adapt and give it external linkage.

* test/src/emacs-module-tests.el (module-function-object): Add unit
test.
parent 5e47c2e5
......@@ -3943,6 +3943,12 @@ make_user_ptr (void (*finalizer) (void *), void *p)
return obj;
}
/* Create a new module function environment object. */
Lisp_Object
make_module_function ()
{
return allocate_misc (Lisp_Misc_Module_Function);
}
#endif
static void
......@@ -6634,6 +6640,7 @@ mark_object (Lisp_Object arg)
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
case Lisp_Misc_Module_Function:
XMISCANY (obj)->gcmarkbit = true;
break;
#endif
......
......@@ -233,6 +233,8 @@ for example, (type-of 1) returns `integer'. */)
case Lisp_Misc_Finalizer:
return Qfinalizer;
#ifdef HAVE_MODULES
case Lisp_Misc_Module_Function:
return Qmodule_function;
case Lisp_Misc_User_Ptr:
return Quser_ptr;
#endif
......@@ -3729,6 +3731,7 @@ syms_of_data (void)
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
#ifdef HAVE_MODULES
DEFSYM (Qmodule_function, "module-function");
DEFSYM (Quser_ptr, "user-ptr");
#endif
DEFSYM (Qfloat, "float");
......
......@@ -62,10 +62,6 @@ enum
/* Function prototype for the module init function. */
typedef int (*emacs_init_function) (struct emacs_runtime *);
/* Function prototype for the module Lisp functions. */
typedef emacs_value (*emacs_subr) (emacs_env *, ptrdiff_t,
emacs_value [], void *);
/* Function prototype for module user-pointer finalizers. These
should not throw C++ exceptions, so emacs-module.h declares the
corresponding interfaces with EMACS_NOEXCEPT. There is only C code
......@@ -102,7 +98,6 @@ struct emacs_runtime_private
struct module_fun_env;
static Lisp_Object module_format_fun_env (const struct module_fun_env *);
static Lisp_Object value_to_lisp (emacs_value);
static emacs_value lisp_to_value (Lisp_Object);
static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *);
......@@ -183,22 +178,6 @@ static emacs_value const module_nil = 0;
} \
do { } while (false)
/* Function environments. */
/* A function environment is an auxiliary structure used by
`module_make_function' to store information about a module
function. It is stored in a save pointer and retrieved by
`internal--module-call'. Its members correspond to the arguments
given to `module_make_function'. */
struct module_fun_env
{
ptrdiff_t min_arity, max_arity;
emacs_subr subr;
void *data;
};
/* Implementation of runtime and environment functions.
......@@ -382,14 +361,13 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
: 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);
Lisp_Object envobj = make_module_function ();
struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
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 = Qnil;
if (documentation)
{
......@@ -677,17 +655,8 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
(ptrdiff_t nargs, Lisp_Object *arglist)
{
Lisp_Object envobj = arglist[0];
/* FIXME: Rather than use a save_value, we should create a new object type.
Making save_value visible to Lisp is wrong. */
CHECK_TYPE (SAVE_VALUEP (envobj), Qsave_value_p, envobj);
struct Lisp_Save_Value *save_value = XSAVE_VALUE (envobj);
CHECK_TYPE (save_type (save_value, 0) == SAVE_POINTER, Qsave_pointer_p, envobj);
/* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
is a module_fun_env pointer. If some other part of Emacs also
exports save_value objects to Elisp, than we may be getting here this
other kind of save_value which will likely hold something completely
different in this field. */
struct module_fun_env *envptr = XSAVE_POINTER (envobj, 0);
CHECK_TYPE (MODULE_FUNCTIONP (envobj), Qmodule_function_p, envobj);
struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
EMACS_INT len = nargs - 1;
eassume (0 <= envptr->min_arity);
if (! (envptr->min_arity <= len
......@@ -976,10 +945,12 @@ module_handle_throw (emacs_env *env, Lisp_Object tag_val)
/* Return a string object that contains a user-friendly
representation of the function environment. */
static Lisp_Object
module_format_fun_env (const struct module_fun_env *env)
Lisp_Object
module_format_fun_env (const struct Lisp_Module_Function *env)
{
/* Try to print a function name if possible. */
/* FIXME: Move this function into print.c, then use prin1-to-string
above. */
const char *path, *sym;
static char const noaddr_format[] = "#<module function at %p>";
char buffer[sizeof noaddr_format + INT_STRLEN_BOUND (intptr_t) + 256];
......@@ -1048,8 +1019,7 @@ syms_of_module (void)
code or modules should not access it. */
Funintern (Qmodule_refs_hash, Qnil);
DEFSYM (Qsave_value_p, "save-value-p");
DEFSYM (Qsave_pointer_p, "save-pointer-p");
DEFSYM (Qmodule_function_p, "module-function-p");
defsubr (&Smodule_load);
......
......@@ -464,6 +464,7 @@ enum Lisp_Misc_Type
Lisp_Misc_Save_Value,
Lisp_Misc_Finalizer,
#ifdef HAVE_MODULES
Lisp_Misc_Module_Function,
Lisp_Misc_User_Ptr,
#endif
/* Currently floats are not a misc type,
......@@ -2385,6 +2386,28 @@ struct Lisp_User_Ptr
void (*finalizer) (void *);
void *p;
};
#include "emacs-module.h"
/* Function prototype for the module Lisp functions. */
typedef emacs_value (*emacs_subr) (emacs_env *, ptrdiff_t,
emacs_value [], void *);
/* Function environments. */
/* A function environment is an auxiliary structure used by
`module_make_function' to store information about a module
function. It is stored in a save pointer and retrieved by
`internal--module-call'. Its members correspond to the arguments
given to `module_make_function'. */
struct Lisp_Module_Function
{
struct Lisp_Misc_Any base;
ptrdiff_t min_arity, max_arity;
emacs_subr subr;
void *data;
};
#endif
/* A finalizer sentinel. */
......@@ -2437,6 +2460,7 @@ union Lisp_Misc
struct Lisp_Finalizer u_finalizer;
#ifdef HAVE_MODULES
struct Lisp_User_Ptr u_user_ptr;
struct Lisp_Module_Function u_module_function;
#endif
};
......@@ -2485,6 +2509,19 @@ XUSER_PTR (Lisp_Object a)
eassert (USER_PTRP (a));
return XUNTAG (a, Lisp_Misc);
}
INLINE bool
MODULE_FUNCTIONP (Lisp_Object o)
{
return MISCP (o) && XMISCTYPE (o) == Lisp_Misc_Module_Function;
}
INLINE struct Lisp_Module_Function *
XMODULE_FUNCTION (Lisp_Object o)
{
eassert (MODULE_FUNCTIONP (o));
return XUNTAG (o, Lisp_Misc);
}
#endif
......@@ -3889,8 +3926,10 @@ extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
#ifdef HAVE_MODULES
/* Defined in alloc.c. */
extern Lisp_Object make_user_ptr (void (*finalizer) (void *), void *p);
extern Lisp_Object make_module_function (void);
/* Defined in emacs-module.c. */
extern Lisp_Object module_format_fun_env (const struct Lisp_Module_Function *);
extern void syms_of_module (void);
#endif
......
......@@ -2103,6 +2103,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
printchar ('>', printcharfun);
break;
}
case Lisp_Misc_Module_Function:
print_string (module_format_fun_env (XMODULE_FUNCTION (obj)),
printcharfun);
break;
#endif
case Lisp_Misc_Finalizer:
......
......@@ -59,6 +59,29 @@
(ert-deftest mod-test-sum-docstring ()
(should (string= (documentation 'mod-test-sum) "Return A + B")))
(ert-deftest module-function-object ()
"Extract and test the implementation of a module function.
This test needs to be changed whenever the implementation
changes."
(let ((func (symbol-function #'mod-test-sum)))
(should (consp func))
(should (equal (length func) 4))
(should (equal (nth 0 func) 'lambda))
(should (equal (nth 1 func) '(&rest args)))
(should (equal (nth 2 func) "Return A + B"))
(let ((body (nth 3 func)))
(should (consp body))
(should (equal (length body) 4))
(should (equal (nth 0 body) #'apply))
(should (equal (nth 1 body) '#'internal--module-call))
(should (equal (nth 3 body) 'args))
(let ((obj (nth 2 body)))
(should (equal (type-of obj) 'module-function))
(should (string-match-p
(rx "#<module function Fmod_test_sum from "
(* nonl) "mod-test" (* nonl) ">")
(prin1-to-string obj)))))))
;;
;; Non-local exists (throw, signal).
;;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment