[Emacs-diffs] master a3e9694: Introduce new misc type for module function

[Philipp Stephani]

branch: master
commit a3e9694078e24d19db860aa4ff8dec8bc34b59b7
Author: Philipp Stephani <address@hidden>
Commit: Philipp <address@hidden>

    Introduce new misc type for module function
    
    This resolves a couple of FIXMEs in emacs-module.c.
    
    * src/lisp.h (MODULE_FUNCTIONP, XMODULE_FUNCTION): New functions.
    
    * src/alloc.c (make_module_function): New function.
    (mark_object): GC support.
    
    * src/data.c (Ftype_of, syms_of_data): Handle module function type.
    
    * src/print.c (print_object): Print support for new type.
    
    * src/emacs-module.c (module_make_function, Finternal_module_call):
    Use new module function type, remove FIXMEs.
    (module_format_fun_env): Adapt and give it external linkage.
    
    * test/src/emacs-module-tests.el (module-function-object): Add unit
    test.
---
 src/alloc.c                    |  7 ++++++
 src/data.c                     |  3 +++
 src/emacs-module.c             | 48 ++++++++----------------------------------
 src/lisp.h                     | 39 ++++++++++++++++++++++++++++++++++
 src/print.c                    |  5 +++++
 test/src/emacs-module-tests.el | 23 ++++++++++++++++++++
 6 files changed, 86 insertions(+), 39 deletions(-)

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