diff --git a/etc/NEWS b/etc/NEWS index 2a4b7014d4e..eeb7c773acc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -946,6 +946,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 26be3b0e07f..361ab2a01ee 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1430,7 +1430,7 @@ the same names as used in the original source code, when possible." ((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 @@ the same names as used in the original source code, when possible." (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 faa14eebb36..b473ebd7ded 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 4242b90e628..25859105ee0 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) @@ -3793,6 +3801,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 dd674e3bc05..345e18b9186 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 0bc1b6c384b..99be4a748ee 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -362,30 +362,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 @@ -648,17 +642,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))) @@ -672,12 +660,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); @@ -709,6 +697,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. */ @@ -1025,7 +1022,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 98d25cc4fed..f472efad52e 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 de3a548cb6c..ec8a8b1c098 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 7e411a80c88..be2e16a7499 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 50be8620bd6..309179d1501 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 0f4bfae00a2..5e78aebf7c3 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -57,33 +57,22 @@ :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 "#") - (prin1-to-string obj))))))) + (should (module-function-p func)) + (should (equal (type-of func) 'module-function)) + (should (string-match-p + (rx bos "#" eos) + (prin1-to-string func))))) ;; ;; Non-local exists (throw, signal). @@ -101,9 +90,7 @@ changes." (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 () @@ -172,3 +159,19 @@ changes." (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