* [PATCH] Reimplement module functions
@ 2017-05-13 14:44 Philipp Stephani
2017-05-13 17:05 ` Eli Zaretskii
0 siblings, 1 reply; 11+ messages in thread
From: Philipp Stephani @ 2017-05-13 14:44 UTC (permalink / raw)
To: emacs-devel; +Cc: Philipp Stephani
Instead of a lambda, create a new type containing all data required to
call the function, and support it in the evaluator. Because this type
now also needs to store the function documentation, it is too big for
Lisp_Misc; use a pseudovector instead. That also has the nice benefit
that we don't have to add special support to the garbage collector.
Since the new type is user-visible, give it a predicate.
Now we can easily support 'help-function-args' and 'func-arity'; add
unit tests for these.
* src/lisp.h (allocate_module_function, MODULE_FUNCTIONP)
(XMODULE_FUNCTION): New pseudovector type 'module function'.
* src/eval.c (FUNCTIONP): Also treat module functions as functions.
(funcall_lambda, Ffuncall, eval_sub): Add support for calling module
functions.
(Ffunc_arity): Add support for detecting the arity of module
functions.
* src/emacs-module.c (module_make_function): Adapt to new structure.
Return module function object directly instead of wrapping it in a
lambda; remove FIXME.
(funcall_module): New function to call module functions. Replaces
`internal--module-call' and is called directly from eval.c.
(syms_of_module): Remove internal helper function, which is no longer
needed.
(module_function_arity): New helper function.
* src/data.c (Ftype_of): Adapt to new implementation.
(Fmodule_function_p, syms_of_data): New user-visible function. Now
that module functions are first-class objects, they deserve a
predicate. Define it even if not compiled with --enable-modules so
that Lisp code doesn't have to check for the function's existence.
* src/doc.c (Fdocumentation): Support module functions.
* src/print.c (print_object): Adapt to new implementation.
* src/alloc.c (mark_object): Specialized garbage collector support is
no longer needed.
* lisp/help.el (help-function-arglist): Support module functions.
While there, simplify the arity calculation by using `func-arity',
which does the right thing for all kinds of functions.
* test/data/emacs-module/mod-test.c: Amend docstring so we can test
the argument list.
* test/src/emacs-module-tests.el (mod-test-sum-docstring): Adapt to
new docstring.
(mod-test-non-local-exit-signal-test): Because `internal--module-call'
is gone, the backtrace has changed and no longer leaks the
implementation.
(module--func-arity): New test for `func-arity'.
(module--help-function-arglist): New test for `help-function-arglist'.
---
lisp/help.el | 19 +++-----
src/alloc.c | 8 ----
src/data.c | 19 +++++++-
src/doc.c | 4 ++
src/emacs-module.c | 50 +++++++++-----------
src/eval.c | 20 ++++++++
src/lisp.h | 97 ++++++++++++++++++++++++---------------
src/print.c | 12 +++--
test/data/emacs-module/mod-test.c | 2 +-
test/src/emacs-module-tests.el | 55 +++++++++++-----------
10 files changed, 165 insertions(+), 121 deletions(-)
diff --git a/lisp/help.el b/lisp/help.el
index 26be3b0e07..361ab2a01e 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1430,7 +1430,7 @@ help-function-arglist
((eq (car-safe def) 'lambda) (nth 1 def))
((eq (car-safe def) 'closure) (nth 2 def))
((or (and (byte-code-function-p def) (integerp (aref def 0)))
- (subrp def))
+ (subrp def) (module-function-p def))
(or (when preserve-names
(let* ((doc (condition-case nil (documentation def) (error nil)))
(docargs (if doc (car (help-split-fundoc doc nil))))
@@ -1446,25 +1446,18 @@ help-function-arglist
(not (string-match "\\." name)))))
(setq valid nil)))
(when valid arglist)))
- (let* ((args-desc (if (not (subrp def))
- (aref def 0)
- (let ((a (subr-arity def)))
- (logior (car a)
- (if (numberp (cdr a))
- (lsh (cdr a) 8)
- (lsh 1 7))))))
- (max (lsh args-desc -8))
- (min (logand args-desc 127))
- (rest (logand args-desc 128))
+ (let* ((arity (func-arity def))
+ (max (cdr arity))
+ (min (car arity))
(arglist ()))
(dotimes (i min)
(push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
- (when (> max min)
+ (when (and (integerp max) (> max min))
(push '&optional arglist)
(dotimes (i (- max min))
(push (intern (concat "arg" (number-to-string (+ 1 i min))))
arglist)))
- (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
+ (unless (integerp max) (push '&rest arglist) (push 'rest arglist))
(nreverse arglist))))
((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
"[Arg list not available until function definition is loaded.]")
diff --git a/src/alloc.c b/src/alloc.c
index faa14eebb3..b473ebd7de 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3942,13 +3942,6 @@ make_user_ptr (void (*finalizer) (void *), void *p)
uptr->p = p;
return obj;
}
-
-/* Create a new module function environment object. */
-Lisp_Object
-make_module_function (void)
-{
- return allocate_misc (Lisp_Misc_Module_Function);
-}
#endif
static void
@@ -6640,7 +6633,6 @@ mark_object (Lisp_Object arg)
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
- case Lisp_Misc_Module_Function:
XMISCANY (obj)->gcmarkbit = true;
break;
#endif
diff --git a/src/data.c b/src/data.c
index 44f7ba0e88..8a16268daf 100644
--- a/src/data.c
+++ b/src/data.c
@@ -233,8 +233,6 @@ 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
@@ -278,6 +276,10 @@ for example, (type-of 1) returns `integer'. */)
else
return t;
}
+#ifdef HAVE_MODULES
+ case PVEC_MODULE_FUNCTION:
+ return Qmodule_function;
+#endif
/* "Impossible" cases. */
case PVEC_XWIDGET:
case PVEC_OTHER:
@@ -494,6 +496,18 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
return Qnil;
}
+DEFUN ("module-function-p", Fmodule_function_p, Smodule_function_p, 1, 1, NULL,
+ doc: /* Return t if OBJECT is a function loaded from a dynamic module. */
+ attributes: const)
+ (Lisp_Object object)
+{
+#ifdef HAVE_MODULES
+ return MODULE_FUNCTIONP (object) ? Qt : Qnil;
+#else
+ return Qnil;
+#endif
+}
+
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
doc: /* Return t if OBJECT is a character or a string. */
attributes: const)
@@ -3790,6 +3804,7 @@ syms_of_data (void)
defsubr (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
+ defsubr (&Smodule_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Sthreadp);
defsubr (&Smutexp);
diff --git a/src/doc.c b/src/doc.c
index dd674e3bc0..3b11001fbd 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -340,6 +340,10 @@ string is passed through `substitute-command-keys'. */)
fun = XCDR (fun);
if (SUBRP (fun))
doc = make_number (XSUBR (fun)->doc);
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (fun))
+ doc = XMODULE_FUNCTION (fun)->documentation;
+#endif
else if (COMPILEDP (fun))
{
if (PVSIZE (fun) <= COMPILED_DOC_STRING)
diff --git a/src/emacs-module.c b/src/emacs-module.c
index cd025a1396..abe2a92276 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -361,30 +361,24 @@ 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));
- Lisp_Object envobj = make_module_function ();
- struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
+ struct Lisp_Module_Function *envptr = allocate_module_function ();
envptr->min_arity = min_arity;
envptr->max_arity = max_arity;
envptr->subr = subr;
envptr->data = data;
- Lisp_Object doc = Qnil;
if (documentation)
{
AUTO_STRING (unibyte_doc, documentation);
- doc = code_convert_string_norecord (unibyte_doc, Qutf_8, false);
+ envptr->documentation =
+ code_convert_string_norecord (unibyte_doc, Qutf_8, false);
}
- /* 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));
+ Lisp_Object envobj;
+ XSET_MODULE_FUNCTION (envobj, envptr);
+ eassert (MODULE_FUNCTIONP (envobj));
- return lisp_to_value (ret);
+ return lisp_to_value (envobj);
}
static emacs_value
@@ -647,17 +641,11 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
return Qt;
}
-DEFUN ("internal--module-call", Finternal_module_call, Sinternal_module_call, 1, MANY, 0,
- doc: /* Internal function to call a module function.
-ENVOBJ is a save pointer to a module_fun_env structure.
-ARGLIST is a list of arguments passed to SUBRPTR.
-usage: (module-call ENVOBJ &rest ARGLIST) */)
- (ptrdiff_t nargs, Lisp_Object *arglist)
+Lisp_Object
+funcall_module (const struct Lisp_Module_Function *const envptr,
+ ptrdiff_t nargs, Lisp_Object *arglist)
{
- Lisp_Object envobj = arglist[0];
- CHECK_TYPE (MODULE_FUNCTIONP (envobj), Qmodule_function_p, envobj);
- struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
- EMACS_INT len = nargs - 1;
+ EMACS_INT len = nargs;
eassume (0 <= envptr->min_arity);
if (! (envptr->min_arity <= len
&& len <= (envptr->max_arity < 0 ? PTRDIFF_MAX : envptr->max_arity)))
@@ -671,12 +659,12 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
USE_SAFE_ALLOCA;
emacs_value *args;
if (plain_values)
- args = (emacs_value *) arglist + 1;
+ args = (emacs_value *) arglist;
else
{
args = SAFE_ALLOCA (len * sizeof *args);
for (ptrdiff_t i = 0; i < len; i++)
- args[i] = lisp_to_value (arglist[i + 1]);
+ args[i] = lisp_to_value (arglist[i]);
}
emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
@@ -708,6 +696,15 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
}
}
+Lisp_Object
+module_function_arity (const struct Lisp_Module_Function *const function)
+{
+ const short minargs = function->min_arity;
+ const short maxargs = function->max_arity;
+ return Fcons (make_number (minargs),
+ maxargs == MANY ? Qmany : make_number (maxargs));
+}
+
\f
/* Helper functions. */
@@ -1022,7 +1019,4 @@ syms_of_module (void)
DEFSYM (Qmodule_function_p, "module-function-p");
defsubr (&Smodule_load);
-
- DEFSYM (Qinternal__module_call, "internal--module-call");
- defsubr (&Sinternal_module_call);
}
diff --git a/src/eval.c b/src/eval.c
index 848955c279..d45d23f8d9 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2263,6 +2263,10 @@ eval_sub (Lisp_Object form)
}
else if (COMPILEDP (fun))
return apply_lambda (fun, original_args, count);
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (fun))
+ return apply_lambda (fun, original_args, count);
+#endif
else
{
if (NILP (fun))
@@ -2689,6 +2693,10 @@ FUNCTIONP (Lisp_Object object)
return XSUBR (object)->max_args != UNEVALLED;
else if (COMPILEDP (object))
return true;
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (object))
+ return true;
+#endif
else if (CONSP (object))
{
Lisp_Object car = XCAR (object);
@@ -2744,6 +2752,10 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
val = funcall_subr (XSUBR (fun), numargs, args + 1);
else if (COMPILEDP (fun))
val = funcall_lambda (fun, numargs, args + 1);
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (fun))
+ val = funcall_module (XMODULE_FUNCTION (fun), numargs, args + 1);
+#endif
else
{
if (NILP (fun))
@@ -2949,6 +2961,10 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
}
lexenv = Qnil;
}
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (fun))
+ return funcall_module (XMODULE_FUNCTION (fun), nargs, arg_vector);
+#endif
else
emacs_abort ();
@@ -3060,6 +3076,10 @@ function with `&rest' args, or `unevalled' for a special form. */)
result = Fsubr_arity (function);
else if (COMPILEDP (function))
result = lambda_arity (function);
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (function))
+ result = module_function_arity (XMODULE_FUNCTION (function));
+#endif
else
{
if (NILP (function))
diff --git a/src/lisp.h b/src/lisp.h
index de3a548cb6..e120e30dd3 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -464,7 +464,6 @@ 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,
@@ -886,6 +885,10 @@ enum pvec_type
PVEC_MUTEX,
PVEC_CONDVAR,
+#ifdef HAVE_MODULES
+ PVEC_MODULE_FUNCTION,
+#endif
+
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
PVEC_CHAR_TABLE,
@@ -2386,28 +2389,6 @@ 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. */
@@ -2460,7 +2441,6 @@ 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
};
@@ -2509,19 +2489,6 @@ 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
\f
@@ -3924,11 +3891,65 @@ Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
#ifdef HAVE_MODULES
+#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 pseudovector. Its members correspond
+ to the arguments given to `module_make_function'. */
+
+struct Lisp_Module_Function
+{
+ struct vectorlike_header header;
+
+ /* Fields traced by GC; these must come first. */
+ Lisp_Object documentation;
+
+ /* Fields ignored by GC. */
+ ptrdiff_t min_arity, max_arity;
+ emacs_subr subr;
+ void *data;
+};
+
+INLINE struct Lisp_Module_Function *
+allocate_module_function (void)
+{
+ return ALLOCATE_PSEUDOVECTOR (struct Lisp_Module_Function,
+ /* Name of the first field to be
+ ignored by GC. */
+ min_arity,
+ PVEC_MODULE_FUNCTION);
+}
+
+INLINE bool
+MODULE_FUNCTIONP (Lisp_Object o)
+{
+ return PSEUDOVECTORP (o, PVEC_MODULE_FUNCTION);
+}
+
+INLINE struct Lisp_Module_Function *
+XMODULE_FUNCTION (Lisp_Object o)
+{
+ eassert (MODULE_FUNCTIONP (o));
+ return XUNTAG (o, Lisp_Vectorlike);
+}
+
+#define XSET_MODULE_FUNCTION(var, ptr) \
+ (XSETPSEUDOVECTOR (var, ptr, PVEC_MODULE_FUNCTION))
+
/* 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 funcall_module (const struct Lisp_Module_Function *,
+ ptrdiff_t, Lisp_Object *);
+extern Lisp_Object module_function_arity (const struct Lisp_Module_Function *);
extern Lisp_Object module_format_fun_env (const struct Lisp_Module_Function *);
extern void syms_of_module (void);
#endif
diff --git a/src/print.c b/src/print.c
index 7e411a80c8..be2e16a749 100644
--- a/src/print.c
+++ b/src/print.c
@@ -2051,6 +2051,13 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
break;
+#ifdef HAVE_MODULES
+ case PVEC_MODULE_FUNCTION:
+ print_string (module_format_fun_env (XMODULE_FUNCTION (obj)),
+ printcharfun);
+ break;
+#endif
+
case PVEC_OTHER:
case PVEC_FREE:
emacs_abort ();
@@ -2103,11 +2110,6 @@ 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:
diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c
index 50be8620bd..309179d150 100644
--- a/test/data/emacs-module/mod-test.c
+++ b/test/data/emacs-module/mod-test.c
@@ -249,7 +249,7 @@ emacs_module_init (struct emacs_runtime *ert)
env->make_function (env, amin, amax, csym, doc, data))
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-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn 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);
DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall,
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index eb7c82b2f6..5a6554c7b9 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -57,35 +57,24 @@
:type 'overflow-error))
(ert-deftest mod-test-sum-docstring ()
- (should (string= (documentation 'mod-test-sum) "Return A + B")))
+ (should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn 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 (or "#<module function Fmod_test_sum from "
- ;; MS-Windows doesn't allow us to get the
- ;; function name, only the address.
- (and "#<module function at 0x"
- (one-or-more hex-digit)
- " from "))
- (* nonl) "mod-test" (* nonl) ">")
- (prin1-to-string obj)))))))
+ (should (module-function-p func))
+ (should (equal (type-of func) 'module-function))
+ (should (string-match-p
+ (rx (or "#<module function Fmod_test_sum from "
+ ;; MS-Windows doesn't allow us to get the
+ ;; function name, only the address.
+ (and "#<module function at 0x"
+ (one-or-more hex-digit)
+ " from "))
+ (* nonl) "mod-test" (* nonl) ">")
+ (prin1-to-string func)))))
;;
;; Non-local exists (throw, signal).
@@ -103,9 +92,7 @@
(mod-test-signal)))
(should (equal debugger-args '(error (error . 56))))
(should (string-match-p
- (rx bol " internal--module-call(" (+ nonl) ?\) ?\n
- " apply(internal--module-call " (+ nonl) ?\) ?\n
- " mod-test-signal()" eol)
+ (rx bol " mod-test-signal()" eol)
backtrace))))
(ert-deftest mod-test-non-local-exit-throw-test ()
@@ -174,3 +161,19 @@ multiply-string
(should (eq (mod-test-vector-fill v-test e) t))
(should (eq (mod-test-vector-eq v-test e) eq-ref))))))
+
+(ert-deftest module--func-arity ()
+ (should (equal (func-arity #'mod-test-return-t) '(1 . 1)))
+ (should (equal (func-arity #'mod-test-sum) '(2 . 2))))
+
+(ert-deftest module--help-function-arglist ()
+ (should (equal (help-function-arglist #'mod-test-return-t :preserve-names)
+ '(arg1)))
+ (should (equal (help-function-arglist #'mod-test-return-t)
+ '(arg1)))
+ (should (equal (help-function-arglist #'mod-test-sum :preserve-names)
+ '(a b)))
+ (should (equal (help-function-arglist #'mod-test-sum)
+ '(arg1 arg2))))
+
+;;; emacs-module-tests.el ends here
--
2.13.0
^ permalink raw reply related [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-13 14:44 [PATCH] Reimplement module functions Philipp Stephani
@ 2017-05-13 17:05 ` Eli Zaretskii
2017-05-14 3:07 ` Noam Postavsky
` (2 more replies)
0 siblings, 3 replies; 11+ messages in thread
From: Eli Zaretskii @ 2017-05-13 17:05 UTC (permalink / raw)
To: Philipp Stephani; +Cc: phst, emacs-devel
> From: Philipp Stephani <p.stephani2@gmail.com>
> Date: Sat, 13 May 2017 16:44:08 +0200
> Cc: Philipp Stephani <phst@google.com>
>
> Instead of a lambda, create a new type containing all data required to
> call the function, and support it in the evaluator. Because this type
> now also needs to store the function documentation, it is too big for
> Lisp_Misc; use a pseudovector instead. That also has the nice benefit
> that we don't have to add special support to the garbage collector.
Thanks.
> +#ifdef HAVE_MODULES
> + else if (MODULE_FUNCTIONP (fun))
> + doc = XMODULE_FUNCTION (fun)->documentation;
> +#endif
I wonder whether it would be cleaner to have MODULE_FUNCTIONP defined
even when HAVE_MODULES is not: it looks like it could save us quite a
few #ifdef's.
> -DEFUN ("internal--module-call", Finternal_module_call, Sinternal_module_call, 1, MANY, 0,
> - doc: /* Internal function to call a module function.
> -ENVOBJ is a save pointer to a module_fun_env structure.
> -ARGLIST is a list of arguments passed to SUBRPTR.
> -usage: (module-call ENVOBJ &rest ARGLIST) */)
> - (ptrdiff_t nargs, Lisp_Object *arglist)
> +Lisp_Object
> +funcall_module (const struct Lisp_Module_Function *const envptr,
> + ptrdiff_t nargs, Lisp_Object *arglist)
> {
I don't think we can simply remove a function that was already present
in one or more Emacs releases. We need to provide a backward
compatibility layer, and definitely also mention this in NEWS.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-13 17:05 ` Eli Zaretskii
@ 2017-05-14 3:07 ` Noam Postavsky
2017-05-14 14:11 ` Eli Zaretskii
2017-05-14 11:40 ` Aurélien Aptel
2017-05-14 18:08 ` Philipp Stephani
2 siblings, 1 reply; 11+ messages in thread
From: Noam Postavsky @ 2017-05-14 3:07 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: Philipp Stephani, Philipp Stephani, Emacs developers
On Sat, May 13, 2017 at 1:05 PM, Eli Zaretskii <eliz@gnu.org> wrote:
>> -DEFUN ("internal--module-call", Finternal_module_call, Sinternal_module_call, 1, MANY, 0,
>> - doc: /* Internal function to call a module function.
>> -ENVOBJ is a save pointer to a module_fun_env structure.
>> -ARGLIST is a list of arguments passed to SUBRPTR.
>> -usage: (module-call ENVOBJ &rest ARGLIST) */)
>> - (ptrdiff_t nargs, Lisp_Object *arglist)
>> +Lisp_Object
>> +funcall_module (const struct Lisp_Module_Function *const envptr,
>> + ptrdiff_t nargs, Lisp_Object *arglist)
>> {
>
> I don't think we can simply remove a function that was already present
> in one or more Emacs releases. We need to provide a backward
> compatibility layer, and definitely also mention this in NEWS.
>
Does an internal function like 'internal--module-call' really need all
that? AFAIK, it was not really meant to be used except in the
implementation of module_make_function.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-13 17:05 ` Eli Zaretskii
2017-05-14 3:07 ` Noam Postavsky
@ 2017-05-14 11:40 ` Aurélien Aptel
2017-05-14 14:30 ` Eli Zaretskii
2017-05-14 18:08 ` Philipp Stephani
2 siblings, 1 reply; 11+ messages in thread
From: Aurélien Aptel @ 2017-05-14 11:40 UTC (permalink / raw)
To: Eli Zaretskii
Cc: Philipp Stephani, Philipp Stephani, Emacs development discussions
On Sat, May 13, 2017 at 7:05 PM, Eli Zaretskii <eliz@gnu.org> wrote:
> I don't think we can simply remove a function that was already present
> in one or more Emacs releases. We need to provide a backward
> compatibility layer, and definitely also mention this in NEWS.
Module support is experimental and this was an internal implementation
detail, I think it's ok to remove it.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-14 3:07 ` Noam Postavsky
@ 2017-05-14 14:11 ` Eli Zaretskii
0 siblings, 0 replies; 11+ messages in thread
From: Eli Zaretskii @ 2017-05-14 14:11 UTC (permalink / raw)
To: Noam Postavsky; +Cc: phst, p.stephani2, emacs-devel
> From: Noam Postavsky <npostavs@users.sourceforge.net>
> Date: Sat, 13 May 2017 23:07:26 -0400
> Cc: Philipp Stephani <p.stephani2@gmail.com>, Philipp Stephani <phst@google.com>,
> Emacs developers <emacs-devel@gnu.org>
>
> > I don't think we can simply remove a function that was already present
> > in one or more Emacs releases. We need to provide a backward
> > compatibility layer, and definitely also mention this in NEWS.
>
> Does an internal function like 'internal--module-call' really need all
> that? AFAIK, it was not really meant to be used except in the
> implementation of module_make_function.
We don't _have_ to do that, but if it's not too hard, why not be nice
to our users and keep providing it? Maybe I'm missing something, but
it seemed to me that a simple wrapper around funcall_module or its
part would do. We can declare it obsolete and remove it at some
future point.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-14 11:40 ` Aurélien Aptel
@ 2017-05-14 14:30 ` Eli Zaretskii
0 siblings, 0 replies; 11+ messages in thread
From: Eli Zaretskii @ 2017-05-14 14:30 UTC (permalink / raw)
To: Aurélien Aptel, John Wiegley; +Cc: phst, p.stephani2, emacs-devel
> From: Aurélien Aptel <aurelien.aptel+emacs@gmail.com>
> Date: Sun, 14 May 2017 13:40:49 +0200
> Cc: Philipp Stephani <p.stephani2@gmail.com>, Philipp Stephani <phst@google.com>,
> Emacs development discussions <emacs-devel@gnu.org>
>
> On Sat, May 13, 2017 at 7:05 PM, Eli Zaretskii <eliz@gnu.org> wrote:
> > I don't think we can simply remove a function that was already present
> > in one or more Emacs releases. We need to provide a backward
> > compatibility layer, and definitely also mention this in NEWS.
>
> Module support is experimental and this was an internal implementation
> detail, I think it's ok to remove it.
I don't think the "experimental" defense will stand in this case: this
function was present in 2 Emacs releases.
It also is easy to provide a back-compatibility shim in this case, so
I think we should. Back-compatibility is nicer to users.
But since others seem to disagree, I'll let John decide on this.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-13 17:05 ` Eli Zaretskii
2017-05-14 3:07 ` Noam Postavsky
2017-05-14 11:40 ` Aurélien Aptel
@ 2017-05-14 18:08 ` Philipp Stephani
2017-05-14 18:09 ` Philipp Stephani
2 siblings, 1 reply; 11+ messages in thread
From: Philipp Stephani @ 2017-05-14 18:08 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: phst, emacs-devel
[-- Attachment #1: Type: text/plain, Size: 1751 bytes --]
Eli Zaretskii <eliz@gnu.org> schrieb am Sa., 13. Mai 2017 um 19:05 Uhr:
> > From: Philipp Stephani <p.stephani2@gmail.com>
> > Date: Sat, 13 May 2017 16:44:08 +0200
> > Cc: Philipp Stephani <phst@google.com>
> >
> > Instead of a lambda, create a new type containing all data required to
> > call the function, and support it in the evaluator. Because this type
> > now also needs to store the function documentation, it is too big for
> > Lisp_Misc; use a pseudovector instead. That also has the nice benefit
> > that we don't have to add special support to the garbage collector.
>
> Thanks.
>
> > +#ifdef HAVE_MODULES
> > + else if (MODULE_FUNCTIONP (fun))
> > + doc = XMODULE_FUNCTION (fun)->documentation;
> > +#endif
>
> I wonder whether it would be cleaner to have MODULE_FUNCTIONP defined
> even when HAVE_MODULES is not: it looks like it could save us quite a
> few #ifdef's.
>
Done.
>
> > -DEFUN ("internal--module-call", Finternal_module_call,
> Sinternal_module_call, 1, MANY, 0,
> > - doc: /* Internal function to call a module function.
> > -ENVOBJ is a save pointer to a module_fun_env structure.
> > -ARGLIST is a list of arguments passed to SUBRPTR.
> > -usage: (module-call ENVOBJ &rest ARGLIST) */)
> > - (ptrdiff_t nargs, Lisp_Object *arglist)
> > +Lisp_Object
> > +funcall_module (const struct Lisp_Module_Function *const envptr,
> > + ptrdiff_t nargs, Lisp_Object *arglist)
> > {
>
> I don't think we can simply remove a function that was already present
> in one or more Emacs releases. We need to provide a backward
> compatibility layer, and definitely also mention this in NEWS.
>
This is purely internal, and we can change implementation details at will.
I've added a NEWS entry, though.
[-- Attachment #2: Type: text/html, Size: 2518 bytes --]
^ permalink raw reply [flat|nested] 11+ messages in thread
* [PATCH] Reimplement module functions
2017-05-14 18:08 ` Philipp Stephani
@ 2017-05-14 18:09 ` Philipp Stephani
2017-05-20 13:37 ` Philipp Stephani
0 siblings, 1 reply; 11+ messages in thread
From: Philipp Stephani @ 2017-05-14 18:09 UTC (permalink / raw)
To: emacs-devel; +Cc: Philipp Stephani
Instead of a lambda, create a new type containing all data required to
call the function, and support it in the evaluator. Because this type
now also needs to store the function documentation, it is too big for
Lisp_Misc; use a pseudovector instead. That also has the nice benefit
that we don't have to add special support to the garbage collector.
Since the new type is user-visible, give it a predicate.
Now we can easily support 'help-function-args' and 'func-arity'; add
unit tests for these.
* src/lisp.h (allocate_module_function, MODULE_FUNCTIONP)
(XMODULE_FUNCTION): New pseudovector type 'module function'.
* src/eval.c (FUNCTIONP): Also treat module functions as functions.
(funcall_lambda, Ffuncall, eval_sub): Add support for calling module
functions.
(Ffunc_arity): Add support for detecting the arity of module
functions.
* src/emacs-module.c (module_make_function): Adapt to new structure.
Return module function object directly instead of wrapping it in a
lambda; remove FIXME.
(funcall_module): New function to call module functions. Replaces
`internal--module-call' and is called directly from eval.c.
(syms_of_module): Remove internal helper function, which is no longer
needed.
(module_function_arity): New helper function.
* src/data.c (Ftype_of): Adapt to new implementation.
(Fmodule_function_p, syms_of_data): New user-visible function. Now
that module functions are first-class objects, they deserve a
predicate. Define it even if not compiled with --enable-modules so
that Lisp code doesn't have to check for the function's existence.
* src/doc.c (Fdocumentation): Support module functions.
* src/print.c (print_object): Adapt to new implementation.
* src/alloc.c (mark_object): Specialized garbage collector support is
no longer needed.
* lisp/help.el (help-function-arglist): Support module functions.
While there, simplify the arity calculation by using `func-arity',
which does the right thing for all kinds of functions.
* test/data/emacs-module/mod-test.c: Amend docstring so we can test
the argument list.
* test/src/emacs-module-tests.el (mod-test-sum-docstring): Adapt to
new docstring.
(mod-test-non-local-exit-signal-test): Because `internal--module-call'
is gone, the backtrace has changed and no longer leaks the
implementation.
(module--func-arity): New test for `func-arity'.
(module--help-function-arglist): New test for `help-function-arglist'.
---
etc/NEWS | 6 +++
lisp/help.el | 19 +++-----
src/alloc.c | 8 ----
src/data.c | 13 +++++-
src/doc.c | 2 +
src/emacs-module.c | 50 +++++++++------------
src/eval.c | 17 +++++--
src/lisp.h | 94 +++++++++++++++++++++++----------------
src/print.c | 12 ++---
test/data/emacs-module/mod-test.c | 2 +-
test/src/emacs-module-tests.el | 55 ++++++++++++-----------
11 files changed, 153 insertions(+), 125 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index 6667a44c29..8668bab5f6 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -923,6 +923,12 @@ instead of its first.
renamed to 'lread--old-style-backquotes'. No user code should use
this variable.
++++
+** Module functions are now implemented slightly differently; in
+particular, the function 'internal--module-call' has been removed.
+Code that depends on undocumented internals of the module system might
+break.
+
\f
* Lisp Changes in Emacs 26.1
diff --git a/lisp/help.el b/lisp/help.el
index 26be3b0e07..361ab2a01e 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1430,7 +1430,7 @@ help-function-arglist
((eq (car-safe def) 'lambda) (nth 1 def))
((eq (car-safe def) 'closure) (nth 2 def))
((or (and (byte-code-function-p def) (integerp (aref def 0)))
- (subrp def))
+ (subrp def) (module-function-p def))
(or (when preserve-names
(let* ((doc (condition-case nil (documentation def) (error nil)))
(docargs (if doc (car (help-split-fundoc doc nil))))
@@ -1446,25 +1446,18 @@ help-function-arglist
(not (string-match "\\." name)))))
(setq valid nil)))
(when valid arglist)))
- (let* ((args-desc (if (not (subrp def))
- (aref def 0)
- (let ((a (subr-arity def)))
- (logior (car a)
- (if (numberp (cdr a))
- (lsh (cdr a) 8)
- (lsh 1 7))))))
- (max (lsh args-desc -8))
- (min (logand args-desc 127))
- (rest (logand args-desc 128))
+ (let* ((arity (func-arity def))
+ (max (cdr arity))
+ (min (car arity))
(arglist ()))
(dotimes (i min)
(push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
- (when (> max min)
+ (when (and (integerp max) (> max min))
(push '&optional arglist)
(dotimes (i (- max min))
(push (intern (concat "arg" (number-to-string (+ 1 i min))))
arglist)))
- (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
+ (unless (integerp max) (push '&rest arglist) (push 'rest arglist))
(nreverse arglist))))
((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
"[Arg list not available until function definition is loaded.]")
diff --git a/src/alloc.c b/src/alloc.c
index faa14eebb3..b473ebd7de 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3942,13 +3942,6 @@ make_user_ptr (void (*finalizer) (void *), void *p)
uptr->p = p;
return obj;
}
-
-/* Create a new module function environment object. */
-Lisp_Object
-make_module_function (void)
-{
- return allocate_misc (Lisp_Misc_Module_Function);
-}
#endif
static void
@@ -6640,7 +6633,6 @@ mark_object (Lisp_Object arg)
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
- case Lisp_Misc_Module_Function:
XMISCANY (obj)->gcmarkbit = true;
break;
#endif
diff --git a/src/data.c b/src/data.c
index 44f7ba0e88..f75b2962d7 100644
--- a/src/data.c
+++ b/src/data.c
@@ -233,8 +233,6 @@ 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
@@ -278,6 +276,8 @@ for example, (type-of 1) returns `integer'. */)
else
return t;
}
+ case PVEC_MODULE_FUNCTION:
+ return Qmodule_function;
/* "Impossible" cases. */
case PVEC_XWIDGET:
case PVEC_OTHER:
@@ -494,6 +494,14 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
return Qnil;
}
+DEFUN ("module-function-p", Fmodule_function_p, Smodule_function_p, 1, 1, NULL,
+ doc: /* Return t if OBJECT is a function loaded from a dynamic module. */
+ attributes: const)
+ (Lisp_Object object)
+{
+ return MODULE_FUNCTIONP (object) ? Qt : Qnil;
+}
+
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
doc: /* Return t if OBJECT is a character or a string. */
attributes: const)
@@ -3790,6 +3798,7 @@ syms_of_data (void)
defsubr (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
+ defsubr (&Smodule_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Sthreadp);
defsubr (&Smutexp);
diff --git a/src/doc.c b/src/doc.c
index dd674e3bc0..345e18b918 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -340,6 +340,8 @@ string is passed through `substitute-command-keys'. */)
fun = XCDR (fun);
if (SUBRP (fun))
doc = make_number (XSUBR (fun)->doc);
+ else if (MODULE_FUNCTIONP (fun))
+ doc = XMODULE_FUNCTION (fun)->documentation;
else if (COMPILEDP (fun))
{
if (PVSIZE (fun) <= COMPILED_DOC_STRING)
diff --git a/src/emacs-module.c b/src/emacs-module.c
index cd025a1396..abe2a92276 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -361,30 +361,24 @@ 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));
- Lisp_Object envobj = make_module_function ();
- struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
+ struct Lisp_Module_Function *envptr = allocate_module_function ();
envptr->min_arity = min_arity;
envptr->max_arity = max_arity;
envptr->subr = subr;
envptr->data = data;
- Lisp_Object doc = Qnil;
if (documentation)
{
AUTO_STRING (unibyte_doc, documentation);
- doc = code_convert_string_norecord (unibyte_doc, Qutf_8, false);
+ envptr->documentation =
+ code_convert_string_norecord (unibyte_doc, Qutf_8, false);
}
- /* 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));
+ Lisp_Object envobj;
+ XSET_MODULE_FUNCTION (envobj, envptr);
+ eassert (MODULE_FUNCTIONP (envobj));
- return lisp_to_value (ret);
+ return lisp_to_value (envobj);
}
static emacs_value
@@ -647,17 +641,11 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
return Qt;
}
-DEFUN ("internal--module-call", Finternal_module_call, Sinternal_module_call, 1, MANY, 0,
- doc: /* Internal function to call a module function.
-ENVOBJ is a save pointer to a module_fun_env structure.
-ARGLIST is a list of arguments passed to SUBRPTR.
-usage: (module-call ENVOBJ &rest ARGLIST) */)
- (ptrdiff_t nargs, Lisp_Object *arglist)
+Lisp_Object
+funcall_module (const struct Lisp_Module_Function *const envptr,
+ ptrdiff_t nargs, Lisp_Object *arglist)
{
- Lisp_Object envobj = arglist[0];
- CHECK_TYPE (MODULE_FUNCTIONP (envobj), Qmodule_function_p, envobj);
- struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
- EMACS_INT len = nargs - 1;
+ EMACS_INT len = nargs;
eassume (0 <= envptr->min_arity);
if (! (envptr->min_arity <= len
&& len <= (envptr->max_arity < 0 ? PTRDIFF_MAX : envptr->max_arity)))
@@ -671,12 +659,12 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
USE_SAFE_ALLOCA;
emacs_value *args;
if (plain_values)
- args = (emacs_value *) arglist + 1;
+ args = (emacs_value *) arglist;
else
{
args = SAFE_ALLOCA (len * sizeof *args);
for (ptrdiff_t i = 0; i < len; i++)
- args[i] = lisp_to_value (arglist[i + 1]);
+ args[i] = lisp_to_value (arglist[i]);
}
emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
@@ -708,6 +696,15 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
}
}
+Lisp_Object
+module_function_arity (const struct Lisp_Module_Function *const function)
+{
+ const short minargs = function->min_arity;
+ const short maxargs = function->max_arity;
+ return Fcons (make_number (minargs),
+ maxargs == MANY ? Qmany : make_number (maxargs));
+}
+
\f
/* Helper functions. */
@@ -1022,7 +1019,4 @@ syms_of_module (void)
DEFSYM (Qmodule_function_p, "module-function-p");
defsubr (&Smodule_load);
-
- DEFSYM (Qinternal__module_call, "internal--module-call");
- defsubr (&Sinternal_module_call);
}
diff --git a/src/eval.c b/src/eval.c
index 848955c279..2a77fc1360 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2261,7 +2261,7 @@ eval_sub (Lisp_Object form)
}
}
}
- else if (COMPILEDP (fun))
+ else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
return apply_lambda (fun, original_args, count);
else
{
@@ -2687,7 +2687,7 @@ FUNCTIONP (Lisp_Object object)
if (SUBRP (object))
return XSUBR (object)->max_args != UNEVALLED;
- else if (COMPILEDP (object))
+ else if (COMPILEDP (object) || MODULE_FUNCTIONP (object))
return true;
else if (CONSP (object))
{
@@ -2742,7 +2742,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
if (SUBRP (fun))
val = funcall_subr (XSUBR (fun), numargs, args + 1);
- else if (COMPILEDP (fun))
+ else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
@@ -2892,7 +2892,8 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
and return the result of evaluation.
- FUN must be either a lambda-expression or a compiled-code object. */
+ FUN must be either a lambda-expression, a compiled-code object,
+ or a module function. */
static Lisp_Object
funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
@@ -2949,6 +2950,10 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
}
lexenv = Qnil;
}
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (fun))
+ return funcall_module (XMODULE_FUNCTION (fun), nargs, arg_vector);
+#endif
else
emacs_abort ();
@@ -3060,6 +3065,10 @@ function with `&rest' args, or `unevalled' for a special form. */)
result = Fsubr_arity (function);
else if (COMPILEDP (function))
result = lambda_arity (function);
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (function))
+ result = module_function_arity (XMODULE_FUNCTION (function));
+#endif
else
{
if (NILP (function))
diff --git a/src/lisp.h b/src/lisp.h
index de3a548cb6..ec8a8b1c09 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -464,7 +464,6 @@ 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,
@@ -885,6 +884,7 @@ enum pvec_type
PVEC_THREAD,
PVEC_MUTEX,
PVEC_CONDVAR,
+ PVEC_MODULE_FUNCTION,
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
@@ -2386,28 +2386,6 @@ 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. */
@@ -2460,7 +2438,6 @@ 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
};
@@ -2509,19 +2486,6 @@ 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
\f
@@ -3923,12 +3887,66 @@ extern void get_backtrace (Lisp_Object array);
Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
+#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 pseudovector. Its members correspond
+ to the arguments given to `module_make_function'. */
+
+struct Lisp_Module_Function
+{
+ struct vectorlike_header header;
+
+ /* Fields traced by GC; these must come first. */
+ Lisp_Object documentation;
+
+ /* Fields ignored by GC. */
+ ptrdiff_t min_arity, max_arity;
+ emacs_subr subr;
+ void *data;
+};
+
+INLINE struct Lisp_Module_Function *
+allocate_module_function (void)
+{
+ return ALLOCATE_PSEUDOVECTOR (struct Lisp_Module_Function,
+ /* Name of the first field to be
+ ignored by GC. */
+ min_arity,
+ PVEC_MODULE_FUNCTION);
+}
+
+INLINE bool
+MODULE_FUNCTIONP (Lisp_Object o)
+{
+ return PSEUDOVECTORP (o, PVEC_MODULE_FUNCTION);
+}
+
+INLINE struct Lisp_Module_Function *
+XMODULE_FUNCTION (Lisp_Object o)
+{
+ eassert (MODULE_FUNCTIONP (o));
+ return XUNTAG (o, Lisp_Vectorlike);
+}
+
+#define XSET_MODULE_FUNCTION(var, ptr) \
+ (XSETPSEUDOVECTOR (var, ptr, PVEC_MODULE_FUNCTION))
+
#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 funcall_module (const struct Lisp_Module_Function *,
+ ptrdiff_t, Lisp_Object *);
+extern Lisp_Object module_function_arity (const struct Lisp_Module_Function *);
extern Lisp_Object module_format_fun_env (const struct Lisp_Module_Function *);
extern void syms_of_module (void);
#endif
diff --git a/src/print.c b/src/print.c
index 7e411a80c8..be2e16a749 100644
--- a/src/print.c
+++ b/src/print.c
@@ -2051,6 +2051,13 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
break;
+#ifdef HAVE_MODULES
+ case PVEC_MODULE_FUNCTION:
+ print_string (module_format_fun_env (XMODULE_FUNCTION (obj)),
+ printcharfun);
+ break;
+#endif
+
case PVEC_OTHER:
case PVEC_FREE:
emacs_abort ();
@@ -2103,11 +2110,6 @@ 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:
diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c
index 50be8620bd..309179d150 100644
--- a/test/data/emacs-module/mod-test.c
+++ b/test/data/emacs-module/mod-test.c
@@ -249,7 +249,7 @@ emacs_module_init (struct emacs_runtime *ert)
env->make_function (env, amin, amax, csym, doc, data))
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-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn 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);
DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall,
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index eb7c82b2f6..5a6554c7b9 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -57,35 +57,24 @@
:type 'overflow-error))
(ert-deftest mod-test-sum-docstring ()
- (should (string= (documentation 'mod-test-sum) "Return A + B")))
+ (should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn 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 (or "#<module function Fmod_test_sum from "
- ;; MS-Windows doesn't allow us to get the
- ;; function name, only the address.
- (and "#<module function at 0x"
- (one-or-more hex-digit)
- " from "))
- (* nonl) "mod-test" (* nonl) ">")
- (prin1-to-string obj)))))))
+ (should (module-function-p func))
+ (should (equal (type-of func) 'module-function))
+ (should (string-match-p
+ (rx (or "#<module function Fmod_test_sum from "
+ ;; MS-Windows doesn't allow us to get the
+ ;; function name, only the address.
+ (and "#<module function at 0x"
+ (one-or-more hex-digit)
+ " from "))
+ (* nonl) "mod-test" (* nonl) ">")
+ (prin1-to-string func)))))
;;
;; Non-local exists (throw, signal).
@@ -103,9 +92,7 @@
(mod-test-signal)))
(should (equal debugger-args '(error (error . 56))))
(should (string-match-p
- (rx bol " internal--module-call(" (+ nonl) ?\) ?\n
- " apply(internal--module-call " (+ nonl) ?\) ?\n
- " mod-test-signal()" eol)
+ (rx bol " mod-test-signal()" eol)
backtrace))))
(ert-deftest mod-test-non-local-exit-throw-test ()
@@ -174,3 +161,19 @@ multiply-string
(should (eq (mod-test-vector-fill v-test e) t))
(should (eq (mod-test-vector-eq v-test e) eq-ref))))))
+
+(ert-deftest module--func-arity ()
+ (should (equal (func-arity #'mod-test-return-t) '(1 . 1)))
+ (should (equal (func-arity #'mod-test-sum) '(2 . 2))))
+
+(ert-deftest module--help-function-arglist ()
+ (should (equal (help-function-arglist #'mod-test-return-t :preserve-names)
+ '(arg1)))
+ (should (equal (help-function-arglist #'mod-test-return-t)
+ '(arg1)))
+ (should (equal (help-function-arglist #'mod-test-sum :preserve-names)
+ '(a b)))
+ (should (equal (help-function-arglist #'mod-test-sum)
+ '(arg1 arg2))))
+
+;;; emacs-module-tests.el ends here
--
2.13.0
^ permalink raw reply related [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-14 18:09 ` Philipp Stephani
@ 2017-05-20 13:37 ` Philipp Stephani
2017-05-20 20:46 ` Paul Eggert
0 siblings, 1 reply; 11+ messages in thread
From: Philipp Stephani @ 2017-05-20 13:37 UTC (permalink / raw)
To: emacs-devel; +Cc: Philipp Stephani
[-- Attachment #1: Type: text/plain, Size: 24578 bytes --]
Philipp Stephani <p.stephani2@gmail.com> schrieb am So., 14. Mai 2017 um
20:09 Uhr:
> Instead of a lambda, create a new type containing all data required to
> call the function, and support it in the evaluator. Because this type
> now also needs to store the function documentation, it is too big for
> Lisp_Misc; use a pseudovector instead. That also has the nice benefit
> that we don't have to add special support to the garbage collector.
>
> Since the new type is user-visible, give it a predicate.
>
> Now we can easily support 'help-function-args' and 'func-arity'; add
> unit tests for these.
>
> * src/lisp.h (allocate_module_function, MODULE_FUNCTIONP)
> (XMODULE_FUNCTION): New pseudovector type 'module function'.
>
> * src/eval.c (FUNCTIONP): Also treat module functions as functions.
> (funcall_lambda, Ffuncall, eval_sub): Add support for calling module
> functions.
> (Ffunc_arity): Add support for detecting the arity of module
> functions.
>
> * src/emacs-module.c (module_make_function): Adapt to new structure.
> Return module function object directly instead of wrapping it in a
> lambda; remove FIXME.
> (funcall_module): New function to call module functions. Replaces
> `internal--module-call' and is called directly from eval.c.
> (syms_of_module): Remove internal helper function, which is no longer
> needed.
> (module_function_arity): New helper function.
>
> * src/data.c (Ftype_of): Adapt to new implementation.
> (Fmodule_function_p, syms_of_data): New user-visible function. Now
> that module functions are first-class objects, they deserve a
> predicate. Define it even if not compiled with --enable-modules so
> that Lisp code doesn't have to check for the function's existence.
>
> * src/doc.c (Fdocumentation): Support module functions.
>
> * src/print.c (print_object): Adapt to new implementation.
>
> * src/alloc.c (mark_object): Specialized garbage collector support is
> no longer needed.
>
> * lisp/help.el (help-function-arglist): Support module functions.
> While there, simplify the arity calculation by using `func-arity',
> which does the right thing for all kinds of functions.
>
> * test/data/emacs-module/mod-test.c: Amend docstring so we can test
> the argument list.
>
> * test/src/emacs-module-tests.el (mod-test-sum-docstring): Adapt to
> new docstring.
> (mod-test-non-local-exit-signal-test): Because `internal--module-call'
> is gone, the backtrace has changed and no longer leaks the
> implementation.
> (module--func-arity): New test for `func-arity'.
> (module--help-function-arglist): New test for `help-function-arglist'.
> ---
> etc/NEWS | 6 +++
> lisp/help.el | 19 +++-----
> src/alloc.c | 8 ----
> src/data.c | 13 +++++-
> src/doc.c | 2 +
> src/emacs-module.c | 50 +++++++++------------
> src/eval.c | 17 +++++--
> src/lisp.h | 94
> +++++++++++++++++++++++----------------
> src/print.c | 12 ++---
> test/data/emacs-module/mod-test.c | 2 +-
> test/src/emacs-module-tests.el | 55 ++++++++++++-----------
> 11 files changed, 153 insertions(+), 125 deletions(-)
>
> diff --git a/etc/NEWS b/etc/NEWS
> index 6667a44c29..8668bab5f6 100644
> --- a/etc/NEWS
> +++ b/etc/NEWS
> @@ -923,6 +923,12 @@ instead of its first.
> renamed to 'lread--old-style-backquotes'. No user code should use
> this variable.
>
> ++++
> +** Module functions are now implemented slightly differently; in
> +particular, the function 'internal--module-call' has been removed.
> +Code that depends on undocumented internals of the module system might
> +break.
> +
>
> * Lisp Changes in Emacs 26.1
>
> diff --git a/lisp/help.el b/lisp/help.el
> index 26be3b0e07..361ab2a01e 100644
> --- a/lisp/help.el
> +++ b/lisp/help.el
> @@ -1430,7 +1430,7 @@ help-function-arglist
> ((eq (car-safe def) 'lambda) (nth 1 def))
> ((eq (car-safe def) 'closure) (nth 2 def))
> ((or (and (byte-code-function-p def) (integerp (aref def 0)))
> - (subrp def))
> + (subrp def) (module-function-p def))
> (or (when preserve-names
> (let* ((doc (condition-case nil (documentation def) (error
> nil)))
> (docargs (if doc (car (help-split-fundoc doc nil))))
> @@ -1446,25 +1446,18 @@ help-function-arglist
> (not (string-match "\\." name)))))
> (setq valid nil)))
> (when valid arglist)))
> - (let* ((args-desc (if (not (subrp def))
> - (aref def 0)
> - (let ((a (subr-arity def)))
> - (logior (car a)
> - (if (numberp (cdr a))
> - (lsh (cdr a) 8)
> - (lsh 1 7))))))
> - (max (lsh args-desc -8))
> - (min (logand args-desc 127))
> - (rest (logand args-desc 128))
> + (let* ((arity (func-arity def))
> + (max (cdr arity))
> + (min (car arity))
> (arglist ()))
> (dotimes (i min)
> (push (intern (concat "arg" (number-to-string (1+ i))))
> arglist))
> - (when (> max min)
> + (when (and (integerp max) (> max min))
> (push '&optional arglist)
> (dotimes (i (- max min))
> (push (intern (concat "arg" (number-to-string (+ 1 i min))))
> arglist)))
> - (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
> + (unless (integerp max) (push '&rest arglist) (push 'rest
> arglist))
> (nreverse arglist))))
> ((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
> "[Arg list not available until function definition is loaded.]")
> diff --git a/src/alloc.c b/src/alloc.c
> index faa14eebb3..b473ebd7de 100644
> --- a/src/alloc.c
> +++ b/src/alloc.c
> @@ -3942,13 +3942,6 @@ make_user_ptr (void (*finalizer) (void *), void *p)
> uptr->p = p;
> return obj;
> }
> -
> -/* Create a new module function environment object. */
> -Lisp_Object
> -make_module_function (void)
> -{
> - return allocate_misc (Lisp_Misc_Module_Function);
> -}
> #endif
>
> static void
> @@ -6640,7 +6633,6 @@ mark_object (Lisp_Object arg)
>
> #ifdef HAVE_MODULES
> case Lisp_Misc_User_Ptr:
> - case Lisp_Misc_Module_Function:
> XMISCANY (obj)->gcmarkbit = true;
> break;
> #endif
> diff --git a/src/data.c b/src/data.c
> index 44f7ba0e88..f75b2962d7 100644
> --- a/src/data.c
> +++ b/src/data.c
> @@ -233,8 +233,6 @@ 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
> @@ -278,6 +276,8 @@ for example, (type-of 1) returns `integer'. */)
> else
> return t;
> }
> + case PVEC_MODULE_FUNCTION:
> + return Qmodule_function;
> /* "Impossible" cases. */
> case PVEC_XWIDGET:
> case PVEC_OTHER:
> @@ -494,6 +494,14 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p,
> Sbyte_code_function_p,
> return Qnil;
> }
>
> +DEFUN ("module-function-p", Fmodule_function_p, Smodule_function_p, 1, 1,
> NULL,
> + doc: /* Return t if OBJECT is a function loaded from a dynamic
> module. */
> + attributes: const)
> + (Lisp_Object object)
> +{
> + return MODULE_FUNCTIONP (object) ? Qt : Qnil;
> +}
> +
> DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
> doc: /* Return t if OBJECT is a character or a string. */
> attributes: const)
> @@ -3790,6 +3798,7 @@ syms_of_data (void)
> defsubr (&Smarkerp);
> defsubr (&Ssubrp);
> defsubr (&Sbyte_code_function_p);
> + defsubr (&Smodule_function_p);
> defsubr (&Schar_or_string_p);
> defsubr (&Sthreadp);
> defsubr (&Smutexp);
> diff --git a/src/doc.c b/src/doc.c
> index dd674e3bc0..345e18b918 100644
> --- a/src/doc.c
> +++ b/src/doc.c
> @@ -340,6 +340,8 @@ string is passed through `substitute-command-keys'.
> */)
> fun = XCDR (fun);
> if (SUBRP (fun))
> doc = make_number (XSUBR (fun)->doc);
> + else if (MODULE_FUNCTIONP (fun))
> + doc = XMODULE_FUNCTION (fun)->documentation;
> else if (COMPILEDP (fun))
> {
> if (PVSIZE (fun) <= COMPILED_DOC_STRING)
> diff --git a/src/emacs-module.c b/src/emacs-module.c
> index cd025a1396..abe2a92276 100644
> --- a/src/emacs-module.c
> +++ b/src/emacs-module.c
> @@ -361,30 +361,24 @@ 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));
>
> - Lisp_Object envobj = make_module_function ();
> - struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
> + struct Lisp_Module_Function *envptr = allocate_module_function ();
> envptr->min_arity = min_arity;
> envptr->max_arity = max_arity;
> envptr->subr = subr;
> envptr->data = data;
>
> - Lisp_Object doc = Qnil;
> if (documentation)
> {
> AUTO_STRING (unibyte_doc, documentation);
> - doc = code_convert_string_norecord (unibyte_doc, Qutf_8, false);
> + envptr->documentation =
> + code_convert_string_norecord (unibyte_doc, Qutf_8, false);
> }
>
> - /* 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));
> + Lisp_Object envobj;
> + XSET_MODULE_FUNCTION (envobj, envptr);
> + eassert (MODULE_FUNCTIONP (envobj));
>
> - return lisp_to_value (ret);
> + return lisp_to_value (envobj);
> }
>
> static emacs_value
> @@ -647,17 +641,11 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1,
> 1, 0,
> return Qt;
> }
>
> -DEFUN ("internal--module-call", Finternal_module_call,
> Sinternal_module_call, 1, MANY, 0,
> - doc: /* Internal function to call a module function.
> -ENVOBJ is a save pointer to a module_fun_env structure.
> -ARGLIST is a list of arguments passed to SUBRPTR.
> -usage: (module-call ENVOBJ &rest ARGLIST) */)
> - (ptrdiff_t nargs, Lisp_Object *arglist)
> +Lisp_Object
> +funcall_module (const struct Lisp_Module_Function *const envptr,
> + ptrdiff_t nargs, Lisp_Object *arglist)
> {
> - Lisp_Object envobj = arglist[0];
> - CHECK_TYPE (MODULE_FUNCTIONP (envobj), Qmodule_function_p, envobj);
> - struct Lisp_Module_Function *envptr = XMODULE_FUNCTION (envobj);
> - EMACS_INT len = nargs - 1;
> + EMACS_INT len = nargs;
> eassume (0 <= envptr->min_arity);
> if (! (envptr->min_arity <= len
> && len <= (envptr->max_arity < 0 ? PTRDIFF_MAX :
> envptr->max_arity)))
> @@ -671,12 +659,12 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
> USE_SAFE_ALLOCA;
> emacs_value *args;
> if (plain_values)
> - args = (emacs_value *) arglist + 1;
> + args = (emacs_value *) arglist;
> else
> {
> args = SAFE_ALLOCA (len * sizeof *args);
> for (ptrdiff_t i = 0; i < len; i++)
> - args[i] = lisp_to_value (arglist[i + 1]);
> + args[i] = lisp_to_value (arglist[i]);
> }
>
> emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
> @@ -708,6 +696,15 @@ usage: (module-call ENVOBJ &rest ARGLIST) */)
> }
> }
>
> +Lisp_Object
> +module_function_arity (const struct Lisp_Module_Function *const function)
> +{
> + const short minargs = function->min_arity;
> + const short maxargs = function->max_arity;
> + return Fcons (make_number (minargs),
> + maxargs == MANY ? Qmany : make_number (maxargs));
> +}
> +
>
> /* Helper functions. */
>
> @@ -1022,7 +1019,4 @@ syms_of_module (void)
> DEFSYM (Qmodule_function_p, "module-function-p");
>
> defsubr (&Smodule_load);
> -
> - DEFSYM (Qinternal__module_call, "internal--module-call");
> - defsubr (&Sinternal_module_call);
> }
> diff --git a/src/eval.c b/src/eval.c
> index 848955c279..2a77fc1360 100644
> --- a/src/eval.c
> +++ b/src/eval.c
> @@ -2261,7 +2261,7 @@ eval_sub (Lisp_Object form)
> }
> }
> }
> - else if (COMPILEDP (fun))
> + else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
> return apply_lambda (fun, original_args, count);
> else
> {
> @@ -2687,7 +2687,7 @@ FUNCTIONP (Lisp_Object object)
>
> if (SUBRP (object))
> return XSUBR (object)->max_args != UNEVALLED;
> - else if (COMPILEDP (object))
> + else if (COMPILEDP (object) || MODULE_FUNCTIONP (object))
> return true;
> else if (CONSP (object))
> {
> @@ -2742,7 +2742,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
>
> if (SUBRP (fun))
> val = funcall_subr (XSUBR (fun), numargs, args + 1);
> - else if (COMPILEDP (fun))
> + else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
> val = funcall_lambda (fun, numargs, args + 1);
> else
> {
> @@ -2892,7 +2892,8 @@ apply_lambda (Lisp_Object fun, Lisp_Object args,
> ptrdiff_t count)
>
> /* Apply a Lisp function FUN to the NARGS evaluated arguments in
> ARG_VECTOR
> and return the result of evaluation.
> - FUN must be either a lambda-expression or a compiled-code object. */
> + FUN must be either a lambda-expression, a compiled-code object,
> + or a module function. */
>
> static Lisp_Object
> funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
> @@ -2949,6 +2950,10 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
> }
> lexenv = Qnil;
> }
> +#ifdef HAVE_MODULES
> + else if (MODULE_FUNCTIONP (fun))
> + return funcall_module (XMODULE_FUNCTION (fun), nargs, arg_vector);
> +#endif
> else
> emacs_abort ();
>
> @@ -3060,6 +3065,10 @@ function with `&rest' args, or `unevalled' for a
> special form. */)
> result = Fsubr_arity (function);
> else if (COMPILEDP (function))
> result = lambda_arity (function);
> +#ifdef HAVE_MODULES
> + else if (MODULE_FUNCTIONP (function))
> + result = module_function_arity (XMODULE_FUNCTION (function));
> +#endif
> else
> {
> if (NILP (function))
> diff --git a/src/lisp.h b/src/lisp.h
> index de3a548cb6..ec8a8b1c09 100644
> --- a/src/lisp.h
> +++ b/src/lisp.h
> @@ -464,7 +464,6 @@ 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,
> @@ -885,6 +884,7 @@ enum pvec_type
> PVEC_THREAD,
> PVEC_MUTEX,
> PVEC_CONDVAR,
> + PVEC_MODULE_FUNCTION,
>
> /* These should be last, check internal_equal to see why. */
> PVEC_COMPILED,
> @@ -2386,28 +2386,6 @@ 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. */
> @@ -2460,7 +2438,6 @@ 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
> };
>
> @@ -2509,19 +2486,6 @@ 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
>
>
> @@ -3923,12 +3887,66 @@ extern void get_backtrace (Lisp_Object array);
> Lisp_Object backtrace_top_function (void);
> extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
>
> +#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 pseudovector. Its members correspond
> + to the arguments given to `module_make_function'. */
> +
> +struct Lisp_Module_Function
> +{
> + struct vectorlike_header header;
> +
> + /* Fields traced by GC; these must come first. */
> + Lisp_Object documentation;
> +
> + /* Fields ignored by GC. */
> + ptrdiff_t min_arity, max_arity;
> + emacs_subr subr;
> + void *data;
> +};
> +
> +INLINE struct Lisp_Module_Function *
> +allocate_module_function (void)
> +{
> + return ALLOCATE_PSEUDOVECTOR (struct Lisp_Module_Function,
> + /* Name of the first field to be
> + ignored by GC. */
> + min_arity,
> + PVEC_MODULE_FUNCTION);
> +}
> +
> +INLINE bool
> +MODULE_FUNCTIONP (Lisp_Object o)
> +{
> + return PSEUDOVECTORP (o, PVEC_MODULE_FUNCTION);
> +}
> +
> +INLINE struct Lisp_Module_Function *
> +XMODULE_FUNCTION (Lisp_Object o)
> +{
> + eassert (MODULE_FUNCTIONP (o));
> + return XUNTAG (o, Lisp_Vectorlike);
> +}
> +
> +#define XSET_MODULE_FUNCTION(var, ptr) \
> + (XSETPSEUDOVECTOR (var, ptr, PVEC_MODULE_FUNCTION))
> +
> #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 funcall_module (const struct Lisp_Module_Function *,
> + ptrdiff_t, Lisp_Object *);
> +extern Lisp_Object module_function_arity (const struct
> Lisp_Module_Function *);
> extern Lisp_Object module_format_fun_env (const struct
> Lisp_Module_Function *);
> extern void syms_of_module (void);
> #endif
> diff --git a/src/print.c b/src/print.c
> index 7e411a80c8..be2e16a749 100644
> --- a/src/print.c
> +++ b/src/print.c
> @@ -2051,6 +2051,13 @@ print_object (Lisp_Object obj, Lisp_Object
> printcharfun, bool escapeflag)
> }
> break;
>
> +#ifdef HAVE_MODULES
> + case PVEC_MODULE_FUNCTION:
> + print_string (module_format_fun_env (XMODULE_FUNCTION (obj)),
> + printcharfun);
> + break;
> +#endif
> +
> case PVEC_OTHER:
> case PVEC_FREE:
> emacs_abort ();
> @@ -2103,11 +2110,6 @@ 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:
> diff --git a/test/data/emacs-module/mod-test.c
> b/test/data/emacs-module/mod-test.c
> index 50be8620bd..309179d150 100644
> --- a/test/data/emacs-module/mod-test.c
> +++ b/test/data/emacs-module/mod-test.c
> @@ -249,7 +249,7 @@ emacs_module_init (struct emacs_runtime *ert)
> env->make_function (env, amin, amax, csym, doc, data))
>
> 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-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn 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);
> DEFUN ("mod-test-non-local-exit-funcall",
> Fmod_test_non_local_exit_funcall,
> diff --git a/test/src/emacs-module-tests.el
> b/test/src/emacs-module-tests.el
> index eb7c82b2f6..5a6554c7b9 100644
> --- a/test/src/emacs-module-tests.el
> +++ b/test/src/emacs-module-tests.el
> @@ -57,35 +57,24 @@
> :type 'overflow-error))
>
> (ert-deftest mod-test-sum-docstring ()
> - (should (string= (documentation 'mod-test-sum) "Return A + B")))
> + (should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn 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 (or "#<module function Fmod_test_sum from "
> - ;; MS-Windows doesn't allow us to get the
> - ;; function name, only the address.
> - (and "#<module function at 0x"
> - (one-or-more hex-digit)
> - " from "))
> - (* nonl) "mod-test" (* nonl) ">")
> - (prin1-to-string obj)))))))
> + (should (module-function-p func))
> + (should (equal (type-of func) 'module-function))
> + (should (string-match-p
> + (rx (or "#<module function Fmod_test_sum from "
> + ;; MS-Windows doesn't allow us to get the
> + ;; function name, only the address.
> + (and "#<module function at 0x"
> + (one-or-more hex-digit)
> + " from "))
> + (* nonl) "mod-test" (* nonl) ">")
> + (prin1-to-string func)))))
>
> ;;
> ;; Non-local exists (throw, signal).
> @@ -103,9 +92,7 @@
> (mod-test-signal)))
> (should (equal debugger-args '(error (error . 56))))
> (should (string-match-p
> - (rx bol " internal--module-call(" (+ nonl) ?\) ?\n
> - " apply(internal--module-call " (+ nonl) ?\) ?\n
> - " mod-test-signal()" eol)
> + (rx bol " mod-test-signal()" eol)
> backtrace))))
>
> (ert-deftest mod-test-non-local-exit-throw-test ()
> @@ -174,3 +161,19 @@ multiply-string
>
> (should (eq (mod-test-vector-fill v-test e) t))
> (should (eq (mod-test-vector-eq v-test e) eq-ref))))))
> +
> +(ert-deftest module--func-arity ()
> + (should (equal (func-arity #'mod-test-return-t) '(1 . 1)))
> + (should (equal (func-arity #'mod-test-sum) '(2 . 2))))
> +
> +(ert-deftest module--help-function-arglist ()
> + (should (equal (help-function-arglist #'mod-test-return-t
> :preserve-names)
> + '(arg1)))
> + (should (equal (help-function-arglist #'mod-test-return-t)
> + '(arg1)))
> + (should (equal (help-function-arglist #'mod-test-sum :preserve-names)
> + '(a b)))
> + (should (equal (help-function-arglist #'mod-test-sum)
> + '(arg1 arg2))))
> +
> +;;; emacs-module-tests.el ends here
> --
> 2.13.0
>
>
Pushed as 31fded0370.
[-- Attachment #2: Type: text/html, Size: 29330 bytes --]
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-20 13:37 ` Philipp Stephani
@ 2017-05-20 20:46 ` Paul Eggert
2017-05-21 20:20 ` Philipp Stephani
0 siblings, 1 reply; 11+ messages in thread
From: Paul Eggert @ 2017-05-20 20:46 UTC (permalink / raw)
To: Philipp Stephani, emacs-devel; +Cc: Philipp Stephani
[-- Attachment #1: Type: text/plain, Size: 545 bytes --]
A couple of minor things I noticed in the recently-installed patch:
> const short minargs = function->min_arity;
In theory at least the arity might be greater than 32767, so this should be
ptrdiff_t. Also, we typically don't use 'const' on locals, as it's not worth the
screen real estate -- it should be easy even for a human reader to tell whether
a local is assigned to later. (Likewise for 'register'.)
While looking into arity range I noticed a couple of other glitches in the
neighborhood, and so installed the attached.
[-- Attachment #2: 0001-Minor-fixes-for-arity-ranges-in-emacs-modules.txt --]
[-- Type: text/plain, Size: 2966 bytes --]
From 848c90e3d43ed7baebab5f2d02d0a9601c6a142b Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 May 2017 13:43:19 -0700
Subject: [PATCH] Minor fixes for arity ranges in emacs modules
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* src/emacs-module.c (module_make_function):
Check that arities fit into fixnums, for func-arity’s benefit.
(funcall_module): Avoid unnecessary conversion to EMACS_INT.
(module_function_arity): Allow arities greater than SHRT_MAX.
---
src/emacs-module.c | 22 +++++++++++-----------
1 file changed, 11 insertions(+), 11 deletions(-)
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 99be4a7..5ab6913 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -358,8 +358,9 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
if (! (0 <= min_arity
&& (max_arity < 0
- ? max_arity == emacs_variadic_function
- : min_arity <= max_arity)))
+ ? (min_arity <= MOST_POSITIVE_FIXNUM
+ && max_arity == emacs_variadic_function)
+ : min_arity <= max_arity && max_arity <= MOST_POSITIVE_FIXNUM)))
xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity));
struct Lisp_Module_Function *envptr = allocate_module_function ();
@@ -646,12 +647,11 @@ Lisp_Object
funcall_module (const struct Lisp_Module_Function *const envptr,
ptrdiff_t nargs, Lisp_Object *arglist)
{
- EMACS_INT len = nargs;
eassume (0 <= envptr->min_arity);
- if (! (envptr->min_arity <= len
- && len <= (envptr->max_arity < 0 ? PTRDIFF_MAX : envptr->max_arity)))
+ if (! (envptr->min_arity <= nargs
+ && (envptr->max_arity < 0 || nargs <= envptr->max_arity)))
xsignal2 (Qwrong_number_of_arguments, module_format_fun_env (envptr),
- make_number (len));
+ make_number (nargs));
emacs_env pub;
struct emacs_env_private priv;
@@ -663,12 +663,12 @@ funcall_module (const struct Lisp_Module_Function *const envptr,
args = (emacs_value *) arglist;
else
{
- args = SAFE_ALLOCA (len * sizeof *args);
- for (ptrdiff_t i = 0; i < len; i++)
+ args = SAFE_ALLOCA (nargs * sizeof *args);
+ for (ptrdiff_t i = 0; i < nargs; i++)
args[i] = lisp_to_value (arglist[i]);
}
- emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
+ emacs_value ret = envptr->subr (&pub, nargs, args, envptr->data);
SAFE_FREE ();
eassert (&priv == pub.private_members);
@@ -700,8 +700,8 @@ funcall_module (const struct Lisp_Module_Function *const envptr,
Lisp_Object
module_function_arity (const struct Lisp_Module_Function *const function)
{
- const short minargs = function->min_arity;
- const short maxargs = function->max_arity;
+ ptrdiff_t minargs = function->min_arity;
+ ptrdiff_t maxargs = function->max_arity;
return Fcons (make_number (minargs),
maxargs == MANY ? Qmany : make_number (maxargs));
}
--
2.7.4
^ permalink raw reply related [flat|nested] 11+ messages in thread
* Re: [PATCH] Reimplement module functions
2017-05-20 20:46 ` Paul Eggert
@ 2017-05-21 20:20 ` Philipp Stephani
0 siblings, 0 replies; 11+ messages in thread
From: Philipp Stephani @ 2017-05-21 20:20 UTC (permalink / raw)
To: Paul Eggert, emacs-devel; +Cc: Philipp Stephani
[-- Attachment #1: Type: text/plain, Size: 416 bytes --]
Paul Eggert <eggert@cs.ucla.edu> schrieb am Sa., 20. Mai 2017 um 22:46 Uhr:
> A couple of minor things I noticed in the recently-installed patch:
>
> > const short minargs = function->min_arity;
>
> In theory at least the arity might be greater than 32767, so this should be
> ptrdiff_t.
>
Yes, the 'short' was a leftover from a previous version that used a misc
type instead of a pseudovector. Thanks for fixing.
[-- Attachment #2: Type: text/html, Size: 721 bytes --]
^ permalink raw reply [flat|nested] 11+ messages in thread
end of thread, other threads:[~2017-05-21 20:20 UTC | newest]
Thread overview: 11+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-05-13 14:44 [PATCH] Reimplement module functions Philipp Stephani
2017-05-13 17:05 ` Eli Zaretskii
2017-05-14 3:07 ` Noam Postavsky
2017-05-14 14:11 ` Eli Zaretskii
2017-05-14 11:40 ` Aurélien Aptel
2017-05-14 14:30 ` Eli Zaretskii
2017-05-14 18:08 ` Philipp Stephani
2017-05-14 18:09 ` Philipp Stephani
2017-05-20 13:37 ` Philipp Stephani
2017-05-20 20:46 ` Paul Eggert
2017-05-21 20:20 ` Philipp Stephani
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.