code.delx.au - gnu-emacs/blob - modules/mod-test/mod-test.c

   1 #include <assert.h>
   2 #include <stdio.h>
   3 #include <emacs_module.h>
   4
   5 int plugin_is_GPL_compatible;
   6
   7 /*
   8  * Always return symbol 't'
   9  */
  10 static emacs_value Fmod_test_return_t (emacs_env *env, int nargs, emacs_value args[], void *data)
  11 {
  12   return env->intern (env, "t");
  13 }
  14
  15
  16 /*
  17  * Expose simple sum function
  18  */
  19 static int64_t sum (int64_t a, int64_t b)
  20 {
  21   return a + b;
  22 }
  23
  24 static emacs_value Fmod_test_sum (emacs_env *env, int nargs, emacs_value args[], void* data)
  25 {
  26   int64_t a = env->extract_integer (env, args[0]);
  27   int64_t b = env->extract_integer (env, args[1]);
  28
  29   int64_t r = sum(a, b);
  30
  31   return env->make_integer (env, r);
  32 }
  33
  34
  35 /*
  36  * Signal '(error 56)
  37  */
  38 static emacs_value Fmod_test_signal (emacs_env *env, int nargs, emacs_value args[], void* data)
  39 {
  40   assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
  41   env->non_local_exit_signal (env, env->intern (env, "error"), env->make_integer (env, 56));
  42   return NULL;
  43 }
  44
  45
  46 /*
  47  * Throw '(tag 65)
  48  */
  49 static emacs_value Fmod_test_throw (emacs_env *env, int nargs, emacs_value args[], void* data)
  50 {
  51   assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
  52   env->non_local_exit_throw (env, env->intern (env, "tag"), env->make_integer (env, 65));
  53   return NULL;
  54 }
  55
  56
  57 /*
  58  * Call argument function, catch all non-local exists and return
  59  * either normal result or a list describing the non-local exit.
  60  */
  61 static emacs_value Fmod_test_non_local_exit_funcall (emacs_env *env, int nargs, emacs_value args[], void* data)
  62 {
  63   assert (nargs == 1);
  64   const emacs_value result = env->funcall (env, args[0], 0, NULL);
  65   emacs_value non_local_exit_symbol, non_local_exit_data;
  66   enum emacs_funcall_exit code = env->non_local_exit_get (env, &non_local_exit_symbol, &non_local_exit_data);
  67   switch (code)
  68     {
  69     case emacs_funcall_exit_return:
  70       return result;
  71     case emacs_funcall_exit_signal:
  72       {
  73         env->non_local_exit_clear (env);
  74         const emacs_value Flist = env->intern (env, "list");
  75         emacs_value list_args[] = {env->intern (env, "signal"), non_local_exit_symbol, non_local_exit_data};
  76         return env->funcall (env, Flist, 3, list_args);
  77       }
  78     case emacs_funcall_exit_throw:
  79       {
  80         env->non_local_exit_clear (env);
  81         const emacs_value Flist = env->intern (env, "list");
  82         emacs_value list_args[] = {env->intern (env, "throw"), non_local_exit_symbol, non_local_exit_data};
  83         return env->funcall (env, Flist, 3, list_args);
  84       }
  85     }
  86   /* never reached */
  87   return env->intern (env, "nil");;
  88 }
  89
  90
  91 /*
  92  * Return a global referrence
  93  */
  94 static emacs_value Fmod_test_globref_make (emacs_env *env, int nargs, emacs_value args[], void* data)
  95 {
  96   /* make a big string and make it global */
  97   size_t i;
  98   char str[26*100];
  99
 100   for (i = 0; i < sizeof (str); i++)
 101     {
 102       str[i] = 'a' + (i % 26);
 103     }
 104
 105   /* we don't need to null-terminate str */
 106   emacs_value lisp_str = env->make_string (env, str, sizeof (str));
 107   return env->make_global_ref (env, lisp_str);
 108 }
 109
 110
 111 /*
 112  * Return a copy of the argument string where every 'a' is replaced with 'b'.
 113  */
 114 static emacs_value Fmod_test_string_a_to_b (emacs_env *env, int nargs, emacs_value args[], void* data)
 115 {
 116   emacs_value lisp_str = args[0];
 117   size_t size = 0;
 118   char * buf = NULL;
 119   size_t i;
 120
 121   env->copy_string_contents (env, lisp_str, buf, &size);
 122   buf = malloc (size);
 123   env->copy_string_contents (env, lisp_str, buf, &size);
 124
 125   for (i = 0; i+1 < size; i++) {
 126     if (buf[i] == 'a')
 127       buf[i] = 'b';
 128   }
 129
 130   return env->make_string (env, buf, size-1);
 131 }
 132
 133
 134 /*
 135  * Embedded pointers in lisp objects.
 136  */
 137
 138 /* C struct (pointer to) that will be embedded */
 139 struct super_struct
 140 {
 141   int amazing_int;
 142   char large_unused_buffer[512];
 143 };
 144
 145 /* Associated finalizer */
 146 static void finalizer (void *p)
 147 {
 148   if (p)
 149     free (p);
 150 }
 151
 152 /*
 153  * Return a new user-pointer to a super_struct, with amazing_int set
 154  * to the passed parameter.
 155  */
 156 static emacs_value Fmod_test_userptr_make (emacs_env *env, int nargs, emacs_value args[], void *data)
 157 {
 158   struct super_struct *p = calloc (1, sizeof(*p));
 159   p->amazing_int = env->extract_integer (env, args[0]);
 160   return env->make_user_ptr (env, finalizer, p);
 161 }
 162
 163 /*
 164  * Return the amazing_int of a passed 'user-pointer to a super_struct'.
 165  */
 166 static emacs_value Fmod_test_userptr_get (emacs_env *env, int nargs, emacs_value args[], void *data)
 167 {
 168   struct super_struct *p = env->get_user_ptr (env, args[0]);
 169   return env->make_integer (env, p->amazing_int);
 170 }
 171
 172
 173 /*
 174  * Fill vector in args[0] with value in args[1]
 175  */
 176 static emacs_value Fmod_test_vector_fill (emacs_env *env, int nargs, emacs_value args[], void *data)
 177 {
 178   size_t i;
 179   emacs_value vec = args[0];
 180   emacs_value val = args[1];
 181   const size_t size = env->vec_size (env, vec);
 182   for (i = 0; i < size; i++)
 183     env->vec_set (env, vec, i, val);
 184   return env->intern (env, "t");
 185 }
 186
 187
 188 /*
 189  * Return whether all elements of vector in args[0] are 'eq' to value in args[1]
 190  */
 191 static emacs_value Fmod_test_vector_eq (emacs_env *env, int nargs, emacs_value args[], void *data)
 192 {
 193   size_t i;
 194   emacs_value vec = args[0];
 195   emacs_value val = args[1];
 196   const size_t size = env->vec_size (env, vec);
 197   for (i = 0; i < size; i++)
 198     if (!env->eq (env, env->vec_get (env, vec, i), val))
 199         return env->intern (env, "nil");
 200   return env->intern (env, "t");
 201 }
 202
 203
 204 /*
 205  * Lisp utilities for easier readability (simple wrappers)
 206  */
 207
 208 /* Provide FEATURE to Emacs */
 209 static void provide (emacs_env *env, const char *feature)
 210 {
 211   emacs_value Qfeat = env->intern (env, feature);
 212   emacs_value Qprovide = env->intern (env, "provide");
 213   emacs_value args[] = { Qfeat };
 214
 215   env->funcall (env, Qprovide, 1, args);
 216 }
 217
 218 /* Binds NAME to FUN */
 219 static void bind_function (emacs_env *env, const char *name, emacs_value Sfun)
 220 {
 221   emacs_value Qfset = env->intern (env, "fset");
 222   emacs_value Qsym = env->intern (env, name);
 223   emacs_value args[] = { Qsym, Sfun };
 224
 225   env->funcall (env, Qfset, 2, args);
 226 }
 227
 228 /*
 229  * Module init function.
 230  */
 231 int emacs_module_init (struct emacs_runtime *ert)
 232 {
 233   emacs_env *env = ert->get_environment (ert);
 234
 235 #define DEFUN(lsym, csym, amin, amax, doc, data) \
 236   bind_function (env, lsym, env->make_function (env, amin, amax, csym, doc, data))
 237
 238   DEFUN ("mod-test-return-t", Fmod_test_return_t, 1, 1, NULL, NULL);
 239   DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B", NULL);
 240   DEFUN ("mod-test-signal", Fmod_test_signal, 0, 0, NULL, NULL);
 241   DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL);
 242   DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall, 1, 1, NULL, NULL);
 243   DEFUN ("mod-test-globref-make", Fmod_test_globref_make, 0, 0, NULL, NULL);
 244   DEFUN ("mod-test-string-a-to-b", Fmod_test_string_a_to_b, 1, 1, NULL, NULL);
 245   DEFUN ("mod-test-userptr-make", Fmod_test_userptr_make, 1, 1, NULL, NULL);
 246   DEFUN ("mod-test-userptr-get", Fmod_test_userptr_get, 1, 1, NULL, NULL);
 247   DEFUN ("mod-test-vector-fill", Fmod_test_vector_fill, 2, 2, NULL, NULL);
 248   DEFUN ("mod-test-vector-eq", Fmod_test_vector_eq, 2, 2, NULL, NULL);
 249
 250 #undef DEFUN
 251
 252   provide (env, "mod-test");
 253   return 0;
 254 }