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
((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))))
(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.]")
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
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
- case Lisp_Misc_Module_Function:
XMISCANY (obj)->gcmarkbit = true;
break;
#endif
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
else
return t;
}
+ case PVEC_MODULE_FUNCTION:
+ return Qmodule_function;
/* "Impossible" cases. */
case PVEC_XWIDGET:
case PVEC_OTHER:
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)
defsubr (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
+ defsubr (&Smodule_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Sthreadp);
defsubr (&Smutexp);
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)
: 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
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)))
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);
}
}
+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. */
DEFSYM (Qmodule_function_p, "module-function-p");
defsubr (&Smodule_load);
-
- DEFSYM (Qinternal__module_call, "internal--module-call");
- defsubr (&Sinternal_module_call);
}
}
}
}
- else if (COMPILEDP (fun))
+ else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
return apply_lambda (fun, original_args, count);
else
{
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))
{
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
{
/* 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,
}
lexenv = Qnil;
}
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (fun))
+ return funcall_module (XMODULE_FUNCTION (fun), nargs, arg_vector);
+#endif
else
emacs_abort ();
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))
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,
PVEC_THREAD,
PVEC_MUTEX,
PVEC_CONDVAR,
+ PVEC_MODULE_FUNCTION,
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
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. */
struct Lisp_Finalizer u_finalizer;
#ifdef HAVE_MODULES
struct Lisp_User_Ptr u_user_ptr;
- struct Lisp_Module_Function u_module_function;
#endif
};
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
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
}
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 ();
printchar ('>', printcharfun);
break;
}
-
- case Lisp_Misc_Module_Function:
- print_string (module_format_fun_env (XMODULE_FUNCTION (obj)),
- printcharfun);
- break;
#endif
case Lisp_Misc_Finalizer:
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,
: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 "#<module function "
- (or "Fmod_test_sum"
- (and "at 0x" (+ 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 bos "#<module function "
+ (or "Fmod_test_sum"
+ (and "at 0x" (+ hex-digit)))
+ (? " from " (* nonl) "mod-test" (* nonl) )
+ ">" eos)
+ (prin1-to-string func)))))
;;
;; Non-local exists (throw, signal).
(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 ()
(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
projects / emacs.git / commitdiff