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

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