add new Lisp_Module type (misc subtype)

Lisp_Module is a new subtype of Misc objects. As other Misc types, it
re-uses the marker free list.

A module must have a custom destructor, which is automatically called
by the GC.

Previous module object using the Save_Value type still work and they
still have to be free explicitely from Lisp. Their use is now
discouraged in modules.

A simple module example + tests are available in modules/memtest.

modules/fmod/test.el

@@ -2,6 +2,10 @@
 
 ;; basic module test should go here
 
+(ert-deftest fmod-module-available ()
+  "Tests if `module-available-p' is t"
+  (should (module-available-p)))
+
 (ert-deftest fmod-require ()
   "Tests bindings after require"
   (skip-unless (not (fboundp 'fmod)))

modules/memtest/Makefile

@@ -0,0 +1,12 @@
+ROOT = ../..
+
+all: memtest.so memtest.doc
+
+%.so: %.o
+	gcc -shared -o $@ $<
+
+%.o: %.c
+	gcc -ggdb3 -Wall -I$(ROOT)/src -I$(ROOT)/lib -fPIC -c $<
+
+%.doc: %.c
+	$(ROOT)/lib-src/make-docfile $< > $@

modules/memtest/memtest.c

@@ -0,0 +1,116 @@
+#include <config.h>
+#include <lisp.h>
+
+int plugin_is_GPL_compatible;
+
+static module_id_t module_id;
+static Lisp_Object MQmemtest;
+
+static int free_count = 0;
+
+struct int_buffer
+{
+  int size;
+  int capacity;
+  int *buf;
+};
+
+#define MXBUF(x) ((struct int_buffer*)(XMODULE (x)->p))
+
+static void buf_init (struct int_buffer *b, int size)
+{
+  b->size = size;
+  b->capacity = (size == 0 ? 1 : size);
+  b->buf = malloc (sizeof (*b->buf) * b->capacity);
+}
+
+static void buf_add (struct int_buffer *b, int val)
+{
+  if (b->size >= b->capacity)
+    {
+      b->capacity *= 2;
+      b->buf = realloc (b->buf, sizeof (*b->buf) * b->capacity);
+    }
+
+  b->buf[b->size++] = val;
+}
+
+static void memtest_destructor (void *p)
+{
+  struct int_buffer *b = p;
+  free (b->buf);
+  free (b);
+  free_count++;
+}
+
+EXFUN (Fmemtest_make, 1);
+DEFUN ("memtest-make", Fmemtest_make, Smemtest_make, 0, 1, 0,
+       doc: "Return an int buffer in the form of a Lisp_Module object.")
+  (Lisp_Object size)
+{
+  struct int_buffer *b;
+
+  b = malloc (sizeof (*b));
+  buf_init (b, NILP (size) ? 0 : XINT (size));
+
+  return module_make_object (module_id, memtest_destructor, (void*)b);
+}
+
+EXFUN (Fmemtest_get, 2);
+DEFUN ("memtest-get", Fmemtest_get, Smemtest_get, 2, 2, 0,
+       doc: "Get value at index N of a memtest buffer.")
+  (Lisp_Object buf, Lisp_Object n)
+{
+  return make_number (MXBUF (buf)->buf[XINT (n)]);
+}
+
+EXFUN (Fmemtest_set, 3);
+DEFUN ("memtest-set", Fmemtest_set, Smemtest_set, 3, 3, 0,
+       doc: "Doc")
+  (Lisp_Object buf, Lisp_Object n, Lisp_Object value)
+{
+  MXBUF (buf)->buf[XINT (n)] = XINT (value);
+  return value;
+}
+
+EXFUN (Fmemtest_size, 1);
+DEFUN ("memtest-size", Fmemtest_size, Smemtest_size, 1, 1, 0,
+       doc: "Doc")
+  (Lisp_Object buf)
+{
+  return make_number (MXBUF (buf)->size);
+}
+
+EXFUN (Fmemtest_add, 2);
+DEFUN ("memtest-add", Fmemtest_add, Smemtest_add, 2, 2, 0,
+       doc: "Doc")
+  (Lisp_Object buf, Lisp_Object value)
+{
+  buf_add (MXBUF (buf), XINT (value));
+  return Qnil;
+}
+
+
+EXFUN (Fmemtest_free_count, 0);
+DEFUN ("memtest-free-count", Fmemtest_free_count, Smemtest_free_count, 0, 0, 0,
+       doc: "Doc")
+  (void)
+{
+  return make_number (free_count);
+}
+
+
+void init ()
+{
+  module_id = module_make_id ();
+  MQmemtest = intern ("memtest");
+
+  defsubr (&Smemtest_make);
+  defsubr (&Smemtest_set);
+  defsubr (&Smemtest_get);
+  defsubr (&Smemtest_add);
+  defsubr (&Smemtest_size);
+  defsubr (&Smemtest_free_count);
+
+  Fprovide (MQmemtest, Qnil);
+}

modules/memtest/test.el

@@ -0,0 +1,20 @@
+(require 'ert)
+(require 'memtest)
+
+(ert-deftest memtest-basic ()
+  "Tests creation/access/release of module objects"
+  (let* ((fc (memtest-free-count))
+         (n 100))
+
+    (let ((b (memtest-make)))
+      (dotimes (i n)
+        (should (= (memtest-size b) i))
+        (memtest-add b i)
+        (should (= (memtest-size b) (1+ i)))))
+
+    ;; force GC
+    (garbage-collect)
+    (sleep-for 1)
+    (garbage-collect)
+
+    (should (= (memtest-free-count) (1+ fc)))))

src/Makefile.in

@@ -366,7 +366,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
 	$(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \
 	emacs.o keyboard.o macros.o keymap.o sysdep.o \
 	buffer.o filelock.o insdel.o marker.o \
-	minibuf.o fileio.o dired.o \
+	minibuf.o fileio.o dired.o module.o \
 	cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \
 	alloc.o data.o doc.o editfns.o callint.o \
 	eval.o floatfns.o fns.o font.o print.o lread.o \

src/alloc.c

@@ -3657,6 +3657,38 @@ free_marker (Lisp_Object marker)
   free_misc (marker);
 }
 
+#ifdef HAVE_LTDL
+/* Create a new module object. */
+Lisp_Object
+module_make_object (module_id_t id, void (*dtor) (void*), void *userptr)
+{
+  Lisp_Object obj;
+  struct Lisp_Module *m;
+
+  eassert (id < MODULE_ID_MAX);
+
+  obj = allocate_misc (Lisp_Misc_Module);
+  m = XMODULE (obj);
+  m->id = id;
+  m->dtor = dtor;
+  m->p = userptr;
+  return obj;
+}
+
+/* Free a module using its own destructor.  */
+void
+module_free_object (Lisp_Object obj)
+{
+  /* every change made here probably needs to be done in
+     sweep_marker() */
+
+  struct Lisp_Module *m = XMODULE (obj);
+  m->dtor (m->p);
+
+  free_misc (obj);
+}
+#endif
+
 
 /* Return a newly created vector or string with specified arguments as
    elements.  If all the arguments are characters that can fit
@@ -6367,6 +6399,12 @@ mark_object (Lisp_Object arg)
 	  mark_overlay (XOVERLAY (obj));
 	  break;
 
+#ifdef HAVE_LTDL
+	case Lisp_Misc_Module:
+	  XMISCANY (obj)->gcmarkbit = 1;
+	  break;
+#endif
+
 	default:
 	  emacs_abort ();
 	}
@@ -6744,9 +6782,23 @@ sweep_misc (void)
       for (i = 0; i < lim; i++)
         {
           if (!mblk->markers[i].m.u_any.gcmarkbit)
-            {
-              if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
-                unchain_marker (&mblk->markers[i].m.u_marker);
+              {
+                switch (mblk->markers[i].m.u_any.type)
+                  {
+                  case Lisp_Misc_Marker:
+                    unchain_marker (&mblk->markers[i].m.u_marker);
+                    break;
+#ifdef HAVE_LTDL
+                  case Lisp_Misc_Module:
+                    /* Module dtor need to be called */
+                    {
+                      /* see module_free_object() */
+                      struct Lisp_Module *m = &mblk->markers[i].m.u_module;
+                      m->dtor (m->p);
+                    }
+                    break;
+#endif
+                  }
               /* Set the type of the freed object to Lisp_Misc_Free.
                  We could leave the type alone, since nobody checks it,
                  but this might catch bugs faster.  */

src/data.c

@@ -224,6 +224,10 @@ for example, (type-of 1) returns `integer'.  */)
 	  return Qoverlay;
 	case Lisp_Misc_Float:
 	  return Qfloat;
+#ifdef HAVE_LTDL
+	case Lisp_Misc_Module:
+	  return Qmodule;
+#endif
 	}
       emacs_abort ();
 
@@ -424,6 +428,17 @@ DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
   return Qnil;
 }
 
+#ifdef HAVE_LTDL
+DEFUN ("modulep", Fmodulep, Smodulep, 1, 1, 0,
+       doc: /* Return t if OBJECT is a module object.  */)
+  (Lisp_Object object)
+{
+  if (MODULEP (object))
+    return Qt;
+  return Qnil;
+}
+#endif
+
 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
        doc: /* Return t if OBJECT is a built-in function.  */)
   (Lisp_Object object)
@@ -3457,6 +3472,9 @@ syms_of_data (void)
   DEFSYM (Qbool_vector_p, "bool-vector-p");
   DEFSYM (Qchar_or_string_p, "char-or-string-p");
   DEFSYM (Qmarkerp, "markerp");
+#ifdef HAVE_LTDL
+  DEFSYM (Qmodulep, "modulep");
+#endif
   DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
   DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
   DEFSYM (Qboundp, "boundp");
@@ -3552,6 +3570,9 @@ syms_of_data (void)
   DEFSYM (Qcons, "cons");
   DEFSYM (Qmarker, "marker");
   DEFSYM (Qoverlay, "overlay");
+#ifdef HAVE_LTDL
+  DEFSYM (Qmodule, "module");
+#endif
   DEFSYM (Qfloat, "float");
   DEFSYM (Qwindow_configuration, "window-configuration");
   DEFSYM (Qprocess, "process");
@@ -3601,6 +3622,9 @@ syms_of_data (void)
   defsubr (&Ssequencep);
   defsubr (&Sbufferp);
   defsubr (&Smarkerp);
+#ifdef HAVE_LTDL
+  defsubr (&Smodulep);
+#endif
   defsubr (&Ssubrp);
   defsubr (&Sbyte_code_function_p);
   defsubr (&Schar_or_string_p);

src/emacs.c

@@ -1403,6 +1403,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
       /* syms_of_keymap (); */
       syms_of_macros ();
       syms_of_marker ();
+      syms_of_module ();
       syms_of_minibuf ();
       syms_of_process ();
       syms_of_search ();