Add loadable modules using Daniel Colascione's ideas.scratch/dynamic-modules-2

See https://lists.gnu.org/archive/html/emacs-devel/2015-02/msg00960.html

* src/Makefile.in (base_obj): add module.o
  (LIBES): add -lltdl

* src/emacs.c (main): add syms_of_module

* src/lisp.h: add syms_of_module

* src/emacs_module.h: New file; emacs API for modules.

* src/module.c: New file; implement API.

* modules/basic/Makefile: New file; build example module on Linux.

* modules/basic/basic.c: New file; simple example module.

1 files changed, 435 insertions, 0 deletions

diff --git a/src/module.c b/src/module.c
new file mode 100644
index 00000000000..d69a4b585e4
--- /dev/null
+++ b/src/module.c
@@ -0,0 +1,435 @@
+/*
+  module.c - Module loading and runtime implementation
+  Copyright (C) 2015 Free Software Foundation, Inc.
+
+  This file is part of GNU Emacs.
+
+  GNU Emacs is free software: you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation, either version 3 of the License, or
+  (at your option) any later version.
+
+  GNU Emacs is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License
+  along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+*/
+
+#include <config.h>
+#include "lisp.h"
+#include "character.h"
+#include "buffer.h"
+
+/* see comment in emacs_module.h at emacs_value for this define */
+#define EMACS_VALUE_TYPE EMACS_INT
+#include "emacs_module.h"
+
+#include <ltdl.h>
+
+/* internal functions */
+void                         syms_of_module         (void);
+static struct emacs_runtime* module_get_runtime     (void);
+static emacs_env*            module_get_environment (struct emacs_runtime *ert);
+
+/* emacs_module.h emacs_env_* functions; same order as there */
+/* FIXME: make_global_reference */
+/* FIXME: free_global_reference */
+/* FIXME: error_check */
+/* FIXME: clear_error */
+/* FIXME: get_error */
+static void                  module_signal_error    (emacs_env *env,
+                                                     const char* msg,
+                                                     emacs_value error_data);
+static emacs_value           module_make_function   (emacs_env *env,
+                                                     int min_arity,
+                                                     int max_arity,
+                                                     emacs_subr subr);
+static emacs_value           module_funcall         (emacs_env *env,
+                                                     emacs_value fun,
+                                                     int nargs,
+                                                     emacs_value args[]);
+static emacs_value           module_intern          (emacs_env *env,
+                                                     const char *name);
+static emacs_value           module_intern_soft     (emacs_env *env,
+                                                     const char *name);
+static void                  module_bind_function   (emacs_env *env,
+                                                     const char *name,
+                                                     emacs_value definition);
+/* FIXME: type_of */
+static int64_t               module_fixnum_to_int   (emacs_env *env,
+                                                     emacs_value n);
+static emacs_value           module_make_fixnum     (emacs_env *env,
+                                                     int64_t n);
+/* FIXME: float_to_c_double */
+/* FIXME: make_float */
+/* FIXME: copy_string_contents */
+static size_t                module_buffer_byte_length (emacs_env *env,
+                                                        emacs_value start,
+                                                        emacs_value end);
+
+static void                  module_copy_buffer_substring (emacs_env   *env,
+                                                           emacs_value  start,
+                                                           emacs_value  end,
+                                                           char        *buffer,
+                                                           size_t      *length_inout);
+static emacs_value           module_make_string     (emacs_env *env,
+                                                     const char *contents);
+static void                  module_message         (emacs_env *env,
+                                                     emacs_value msg);
+static emacs_value           module_symbol_value    (emacs_env *env,
+                                                     emacs_value symbol);
+
+
+static struct emacs_runtime* module_get_runtime (void)
+{
+  /* FIXME: why do we need module_get_runtime, as opposed to just module_get_environment? */
+  struct emacs_runtime *ert = xzalloc (sizeof *ert);
+
+  ert->size = sizeof *ert;
+  ert->get_environment = module_get_environment;
+
+  return ert;
+}
+
+static emacs_env* module_get_environment (struct emacs_runtime *ert)
+{
+  /* FIXME: error if not on main emacs thread? */
+
+  emacs_env *env = xzalloc (sizeof *env);
+
+  env->size                  = sizeof *env;
+  env->Qt_value              = (emacs_value) Qt;
+  env->Qnil_value            = (emacs_value) Qnil;
+  /* FIXME: make_global_reference */
+  /* FIXME: free_global_reference */
+  /* FIXME: error_check */
+  /* FIXME: clear_error */
+  /* FIXME: get_error */
+  env->signal_error          = module_signal_error;
+  env->make_function         = module_make_function;
+  env->funcall               = module_funcall;
+  env->intern                = module_intern;
+  env->intern_soft           = module_intern_soft;
+  env->bind_function         = module_bind_function;
+  env->fixnum_to_int         = module_fixnum_to_int;
+  env->make_fixnum           = module_make_fixnum;
+  /* FIXME: copy_string_contents */
+  env->buffer_byte_length    = module_buffer_byte_length;
+  env->copy_buffer_substring = module_copy_buffer_substring;
+  env->make_string           = module_make_string;
+  env->message               = module_message;
+  env->symbol_value          = module_symbol_value;
+
+  return env;
+}
+
+static emacs_value module_make_fixnum (emacs_env *env, int64_t n)
+{
+  return (emacs_value) make_number (n);
+}
+
+static int64_t module_fixnum_to_int (emacs_env *env, emacs_value n)
+{
+  return (int64_t) XINT ((Lisp_Object) n);
+}
+
+static emacs_value module_intern (emacs_env *env, const char *name)
+{
+  return (emacs_value) intern (name);
+}
+
+static emacs_value module_intern_soft (emacs_env *env, const char *name)
+{
+  register ptrdiff_t len = strlen (name);
+  register Lisp_Object tem = oblookup (Vobarray, name, len, len);
+
+  if (INTEGERP (tem))
+    return (emacs_value) Qnil;
+  else
+    return (emacs_value) tem;
+}
+
+static void module_bind_function (emacs_env *env,
+                                  const char *name,
+                                  emacs_value definition)
+{
+  Lisp_Object symbol = intern (name);
+  set_symbol_function (symbol, (Lisp_Object) definition);
+}
+
+static void module_signal_error (emacs_env *env,
+                                 const char* msg,
+                                 emacs_value error_data)
+{
+  signal_error (msg, (Lisp_Object) (error_data));
+}
+
+static emacs_value module_make_function (emacs_env *env,
+                                         int min_arity,
+                                         int max_arity,
+                                         emacs_subr subr)
+{
+  /*
+    (function
+     (lambda
+      (&rest arglist)
+      (module-call
+       envptr
+       subrptr
+       arglist)))
+  */
+  /* FIXME: allow for doc string and interactive */
+  Lisp_Object Qrest = intern ("&rest");
+  Lisp_Object Qarglist = intern ("arglist");
+  Lisp_Object Qmodule_call = intern ("module-call");
+  Lisp_Object envptr = make_save_ptr ((void*) env);
+  Lisp_Object subrptr = make_save_ptr ((void*) subr);
+
+  Lisp_Object form = list2 (Qfunction,
+                            list3 (Qlambda,
+                                   list2 (Qrest, Qarglist),
+                                   list4 (Qmodule_call,
+                                          envptr,
+                                          subrptr,
+                                          Qarglist)));
+
+  struct gcpro gcpro1;
+  GCPRO1 (Qform);
+  Lisp_Object ret = Feval (form, Qnil);
+  UNGCPRO;
+
+  return (emacs_value) ret;
+}
+
+static emacs_value module_funcall (emacs_env *env,
+                                   emacs_value fun,
+                                   int nargs,
+                                   emacs_value args[])
+{
+  /*
+   *  Make a new Lisp_Object array starting with the function as the
+   *  first arg, because that's what Ffuncall takes
+   */
+  int i;
+  Lisp_Object *newargs = xmalloc ((nargs+1) * sizeof (*newargs));
+
+  newargs[0] = (Lisp_Object) fun;
+  for (i = 0; i < nargs; i++)
+    newargs[1 + i] = (Lisp_Object) args[i];
+
+  struct gcpro gcpro1;
+  GCPRO1 (newargs[0]);
+  Lisp_Object ret = Ffuncall (nargs+1, newargs);
+  UNGCPRO;
+
+  xfree (newargs);
+  return (emacs_value) ret;
+}
+
+static size_t module_buffer_byte_length (emacs_env *env,
+                                         emacs_value start,
+                                         emacs_value end)
+{
+  Lisp_Object start_1 = (Lisp_Object)start;
+  Lisp_Object end_1   = (Lisp_Object)end;
+
+  validate_region (&start_1, &end_1);
+
+  {
+    ptrdiff_t start_byte = CHAR_TO_BYTE (XINT (start_1));
+    ptrdiff_t end_byte   = CHAR_TO_BYTE (XINT (end_1));
+
+    return (size_t) end_byte - start_byte;
+  }
+}
+
+static void module_copy_buffer_substring (emacs_env   *env,
+                                          emacs_value  start,
+                                          emacs_value  end,
+                                          char        *buffer,
+                                          size_t      *length_inout)
+{
+  /* Copied from editfns.c "buffer-substring-no-properties" and make_buffer_string_both */
+  Lisp_Object start_1 = (Lisp_Object)start;
+  Lisp_Object end_1   = (Lisp_Object)end;
+
+  validate_region (&start_1, &end_1);
+
+  {
+    ptrdiff_t start      = XINT (start_1);
+    ptrdiff_t start_byte = CHAR_TO_BYTE (start);
+    ptrdiff_t end        = XINT (end_1);
+    ptrdiff_t end_byte   = CHAR_TO_BYTE (end);
+    ptrdiff_t beg0, end0, beg1, end1;
+    size_t    size;
+
+    if (end_byte - start_byte > *length_inout)
+      {
+        /* buffer too small */
+        /* FIXME: could copy less than requested, but that's
+           complicated for multi-byte characters */
+        signal_error ("module_copy_buffer_substring: buffer too small", Qnil);
+      }
+
+  if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
+    {
+      /* Two regions, before and after the gap.  */
+      beg0 = start_byte;
+      end0 = GPT_BYTE;
+      beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
+      end1 = end_byte + GAP_SIZE - BEG_BYTE;
+    }
+  else
+    {
+      /* One region, before the gap.  */
+      beg0 = start_byte;
+      end0 = end_byte;
+      beg1 = -1;
+      end1 = -1;
+    }
+
+    size = end0 - beg0;
+
+    /* FIXME: need to decode? See external process stuff. */
+
+    /* BYTE_POS_ADDR handles one region after the gap */
+    memcpy (buffer, BYTE_POS_ADDR (beg0), size);
+    if (beg1 != -1)
+      memcpy (buffer + size, BEG_ADDR + beg1, end1 - beg1);
+  }
+}
+
+static emacs_value module_make_string (emacs_env *env, const char *contents)
+{
+  return (emacs_value) make_string (contents, strlen (contents));
+}
+
+static void module_message (emacs_env *env,
+                            emacs_value msg)
+{
+  message3 ((Lisp_Object) msg);
+}
+
+static emacs_value module_symbol_value (emacs_env *env,
+                                        emacs_value symbol)
+{
+  Lisp_Object val= find_symbol_value ((Lisp_Object) symbol);
+  if (!EQ (val, Qunbound))
+    return (emacs_value) val;
+
+  xsignal1 (Qvoid_variable, (Lisp_Object) symbol);
+}
+
+DEFUN ("module-call", Fmodule_call, Smodule_call, 3, 3, 0,
+       doc: "Call a module function")
+  (Lisp_Object envptr, Lisp_Object subrptr, Lisp_Object arglist)
+{
+  int len = XINT (Flength (arglist));
+  emacs_value *args = xzalloc (len * sizeof (*args));
+  int i;
+
+  for (i = 0; i < len; i++)
+    {
+      args[i] = (emacs_value) XCAR (arglist);
+      arglist = XCDR (arglist);
+    }
+
+  emacs_env *env = (emacs_env*) XSAVE_POINTER (envptr, 0);
+  emacs_subr subr = (emacs_subr) XSAVE_POINTER (subrptr, 0);
+  emacs_value ret = subr (env, len, args);
+  return (Lisp_Object) ret;
+}
+
+static int lt_init_done = 0;
+
+EXFUN (Fmodule_load, 1);
+DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
+       doc: /* Load module FILE.  */)
+  (Lisp_Object file)
+{
+  lt_dlhandle handle;
+  emacs_init_function module_init;
+  void *gpl_sym;
+  Lisp_Object doc_name, args[2];
+
+  /* init libtool once per emacs process */
+  if (!lt_init_done)
+    {
+      int ret = lt_dlinit ();
+      if (ret)
+        {
+          const char* s = lt_dlerror ();
+          error ("ltdl init fail: %s", s);
+        }
+      lt_init_done = 1;
+    }
+
+  /* FIXME: check for libltdl, load it if available; don't require
+     --with-ltdl at configure time. See image.c for example. */
+
+  CHECK_STRING (file);
+  handle = lt_dlopen (SDATA (file));
+  if (!handle)
+    error ("Cannot load file %s : %s", SDATA (file), lt_dlerror());
+
+  gpl_sym = lt_dlsym (handle, "plugin_is_GPL_compatible");
+  if (!gpl_sym)
+    error ("Module %s is not GPL compatible", SDATA (file));
+
+  module_init = (emacs_init_function) lt_dlsym (handle, "emacs_module_init");
+  if (!module_init)
+    error ("Module %s does not have an init function.", SDATA (file));
+
+
+  int r = module_init (module_get_runtime ());
+
+  /* Errors are reported by calling env->signal_error. FIXME: so why does module_init return anything? */
+  return Qt;
+}
+
+EXFUN (Fmodule_unsafe_unload, 1);
+DEFUN ("module-unsafe-unload", Fmodule_unsafe_unload, Smodule_unsafe_unload, 1, 1, 0,
+       doc: /* Unload module FILE; does not undefine any functions defined by the module.
+This permits re-compiling and re-loading while developing the module,
+but is otherwise not recommended.  */)
+  (Lisp_Object file)
+{
+  lt_dlhandle handle;
+
+  if (!lt_init_done)
+    {
+      error ("no module loaded");
+    }
+
+  CHECK_STRING (file);
+  handle = lt_dlopen (SDATA (file));
+  if (!handle)
+    error ("file not loaded %s : %s", SDATA (file), lt_dlerror());
+
+  if (lt_dlclose (handle))
+    error ("Module %s not unloaded: %s", SDATA (file), lt_dlerror());
+
+  return Qt;
+}
+
+EXFUN (Fmodule_emacs_value_type, 0);
+DEFUN ("module-emacs_value-type", Fmodule_emacs_value_type, Smodule_emacs_value_type, 0, 0, 0,
+       doc: /* Return a string specifying the type for emacs_value in emacs_modules.h.  */)
+  ()
+{
+  if (sizeof (EMACS_INT) == 4) /* 4 bytes == 32 bits */
+    return make_string ("uint32_t", 8);
+  else
+    return make_string ("uint64_t", 8);
+}
+
+void syms_of_module (void)
+{
+  defsubr (&Smodule_call);
+  defsubr (&Smodule_load);
+  defsubr (&Smodule_unsafe_unload);
+  defsubr (&Smodule_emacs_value_type);
+}