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, ptrdiff_t nargs, emacs_value args[],
  30                     void *data)
  31 {
  32   return env->intern (env, "t");
  33 }
  34
  35 /* Expose simple sum function.  */
  36 static intmax_t
  37 sum (intmax_t a, intmax_t b)
  38 {
  39   return a + b;
  40 }
  41
  42 static emacs_value
  43 Fmod_test_sum (emacs_env *env, ptrdiff_t nargs, emacs_value args[], void *data)
  44 {
  45   assert (nargs == 2);
  46
  47   intmax_t a = env->extract_integer (env, args[0]);
  48   intmax_t b = env->extract_integer (env, args[1]);
  49
  50   intmax_t r = sum (a, b);
  51
  52   return env->make_integer (env, r);
  53 }
  54
  55
  56 /* Signal '(error 56).  */
  57 static emacs_value
  58 Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
  59                   void *data)
  60 {
  61   assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
  62   env->non_local_exit_signal (env, env->intern (env, "error"),
  63                               env->make_integer (env, 56));
  64   return NULL;
  65 }
  66
  67
  68 /* Throw '(tag 65).  */
  69 static emacs_value
  70 Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
  71                  void *data)
  72 {
  73   assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
  74   env->non_local_exit_throw (env, env->intern (env, "tag"),
  75                              env->make_integer (env, 65));
  76   return NULL;
  77 }
  78
  79
  80 /* Call argument function, catch all non-local exists and return
  81    either normal result or a list describing the non-local exit.  */
  82 static emacs_value
  83 Fmod_test_non_local_exit_funcall (emacs_env *env, ptrdiff_t nargs,
  84                                   emacs_value args[], void *data)
  85 {
  86   assert (nargs == 1);
  87   emacs_value result = env->funcall (env, args[0], 0, NULL);
  88   emacs_value non_local_exit_symbol, non_local_exit_data;
  89   enum emacs_funcall_exit code
  90     = env->non_local_exit_get (env, &non_local_exit_symbol,
  91                                &non_local_exit_data);
  92   switch (code)
  93     {
  94     case emacs_funcall_exit_return:
  95       return result;
  96     case emacs_funcall_exit_signal:
  97       {
  98         env->non_local_exit_clear (env);
  99         emacs_value Flist = env->intern (env, "list");
 100         emacs_value list_args[] = {env->intern (env, "signal"),
 101                                    non_local_exit_symbol, non_local_exit_data};
 102         return env->funcall (env, Flist, 3, list_args);
 103       }
 104     case emacs_funcall_exit_throw:
 105       {
 106         env->non_local_exit_clear (env);
 107         emacs_value Flist = env->intern (env, "list");
 108         emacs_value list_args[] = {env->intern (env, "throw"),
 109                                    non_local_exit_symbol, non_local_exit_data};
 110         return env->funcall (env, Flist, 3, list_args);
 111       }
 112     }
 113
 114   /* Never reached.  */
 115   return env->intern (env, "nil");;
 116 }
 117
 118
 119 /* Return a global reference.  */
 120 static emacs_value
 121 Fmod_test_globref_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
 122                         void *data)
 123 {
 124   /* Make a big string and make it global.  */
 125   char str[26 * 100];
 126   for (int i = 0; i < sizeof str; i++)
 127     str[i] = 'a' + (i % 26);
 128
 129   /* We don't need to null-terminate str.  */
 130   emacs_value lisp_str = env->make_string (env, str, sizeof str);
 131   return env->make_global_ref (env, lisp_str);
 132 }
 133
 134
 135 /* Return a copy of the argument string where every 'a' is replaced
 136    with 'b'.  */
 137 static emacs_value
 138 Fmod_test_string_a_to_b (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
 139                          void *data)
 140 {
 141   emacs_value lisp_str = args[0];
 142   ptrdiff_t size = 0;
 143   char * buf = NULL;
 144
 145   env->copy_string_contents (env, lisp_str, buf, &size);
 146   buf = malloc (size);
 147   env->copy_string_contents (env, lisp_str, buf, &size);
 148
 149   for (ptrdiff_t i = 0; i + 1 < size; i++)
 150     if (buf[i] == 'a')
 151       buf[i] = 'b';
 152
 153   return env->make_string (env, buf, size - 1);
 154 }
 155
 156
 157 /* Embedded pointers in lisp objects.  */
 158
 159 /* C struct (pointer to) that will be embedded.  */
 160 struct super_struct
 161 {
 162   int amazing_int;
 163   char large_unused_buffer[512];
 164 };
 165
 166 /* Return a new user-pointer to a super_struct, with amazing_int set
 167    to the passed parameter.  */
 168 static emacs_value
 169 Fmod_test_userptr_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
 170                         void *data)
 171 {
 172   struct super_struct *p = calloc (1, sizeof *p);
 173   p->amazing_int = env->extract_integer (env, args[0]);
 174   return env->make_user_ptr (env, free, p);
 175 }
 176
 177 /* Return the amazing_int of a passed 'user-pointer to a super_struct'.  */
 178 static emacs_value
 179 Fmod_test_userptr_get (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
 180                        void *data)
 181 {
 182   struct super_struct *p = env->get_user_ptr (env, args[0]);
 183   return env->make_integer (env, p->amazing_int);
 184 }
 185
 186
 187 /* Fill vector in args[0] with value in args[1].  */
 188 static emacs_value
 189 Fmod_test_vector_fill (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
 190                        void *data)
 191 {
 192   emacs_value vec = args[0];
 193   emacs_value val = args[1];
 194   ptrdiff_t size = env->vec_size (env, vec);
 195   for (ptrdiff_t i = 0; i < size; i++)
 196     env->vec_set (env, vec, i, val);
 197   return env->intern (env, "t");
 198 }
 199
 200
 201 /* Return whether all elements of vector in args[0] are 'eq' to value
 202    in args[1].  */
 203 static emacs_value
 204 Fmod_test_vector_eq (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
 205                      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 }