mod-test.c 7.61 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
/* Test GNU Emacs modules.

Copyright 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/>.  */

20 21
#include <assert.h>
#include <stdio.h>
22
#include <emacs-module.h>
23 24 25

int plugin_is_GPL_compatible;

26 27 28
/* Always return symbol 't'.  */
static emacs_value
Fmod_test_return_t (emacs_env *env, int nargs, emacs_value args[], void *data)
29 30 31 32
{
  return env->intern (env, "t");
}

33
/* Expose simple sum function.  */
34 35
static intmax_t
sum (intmax_t a, intmax_t b)
36 37 38 39
{
  return a + b;
}

40 41
static emacs_value
Fmod_test_sum (emacs_env *env, int nargs, emacs_value args[], void *data)
42
{
43 44
  intmax_t a = env->extract_integer (env, args[0]);
  intmax_t b = env->extract_integer (env, args[1]);
45

46
  intmax_t r = sum (a, b);
47 48 49 50 51

  return env->make_integer (env, r);
}


52 53 54
/* Signal '(error 56).  */
static emacs_value
Fmod_test_signal (emacs_env *env, int nargs, emacs_value args[], void *data)
55 56
{
  assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
57 58
  env->non_local_exit_signal (env, env->intern (env, "error"),
			      env->make_integer (env, 56));
59 60 61 62
  return NULL;
}


63 64 65
/* Throw '(tag 65).  */
static emacs_value
Fmod_test_throw (emacs_env *env, int nargs, emacs_value args[], void *data)
66 67
{
  assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
68 69
  env->non_local_exit_throw (env, env->intern (env, "tag"),
			     env->make_integer (env, 65));
70 71 72 73
  return NULL;
}


74 75 76 77 78
/* Call argument function, catch all non-local exists and return
   either normal result or a list describing the non-local exit.  */
static emacs_value
Fmod_test_non_local_exit_funcall (emacs_env *env, int nargs, emacs_value args[],
				  void *data)
79 80
{
  assert (nargs == 1);
Paul Eggert's avatar
Paul Eggert committed
81
  emacs_value result = env->funcall (env, args[0], 0, NULL);
82
  emacs_value non_local_exit_symbol, non_local_exit_data;
83 84 85
  enum emacs_funcall_exit code
    = env->non_local_exit_get (env, &non_local_exit_symbol,
			       &non_local_exit_data);
86 87 88 89 90 91 92
  switch (code)
    {
    case emacs_funcall_exit_return:
      return result;
    case emacs_funcall_exit_signal:
      {
        env->non_local_exit_clear (env);
Paul Eggert's avatar
Paul Eggert committed
93
        emacs_value Flist = env->intern (env, "list");
94 95
        emacs_value list_args[] = {env->intern (env, "signal"),
				   non_local_exit_symbol, non_local_exit_data};
96 97 98 99 100
        return env->funcall (env, Flist, 3, list_args);
      }
    case emacs_funcall_exit_throw:
      {
        env->non_local_exit_clear (env);
Paul Eggert's avatar
Paul Eggert committed
101
        emacs_value Flist = env->intern (env, "list");
102 103
        emacs_value list_args[] = {env->intern (env, "throw"),
				   non_local_exit_symbol, non_local_exit_data};
104 105 106
        return env->funcall (env, Flist, 3, list_args);
      }
    }
107 108

  /* Never reached.  */
109 110 111 112
  return env->intern (env, "nil");;
}


113 114 115 116
/* Return a global referrence.  */
static emacs_value
Fmod_test_globref_make (emacs_env *env, int nargs, emacs_value args[],
			void *data)
117
{
118 119 120 121
  /* Make a big string and make it global.  */
  char str[26 * 100];
  for (size_t i = 0; i < sizeof str; i++)
    str[i] = 'a' + (i % 26);
122

123 124
  /* We don't need to null-terminate str.  */
  emacs_value lisp_str = env->make_string (env, str, sizeof str);
125 126 127 128
  return env->make_global_ref (env, lisp_str);
}


129 130 131 132 133
/* Return a copy of the argument string where every 'a' is replaced
   with 'b'.  */
static emacs_value
Fmod_test_string_a_to_b (emacs_env *env, int nargs, emacs_value args[],
			 void *data)
134 135 136 137 138 139 140 141 142
{
  emacs_value lisp_str = args[0];
  size_t size = 0;
  char * buf = NULL;

  env->copy_string_contents (env, lisp_str, buf, &size);
  buf = malloc (size);
  env->copy_string_contents (env, lisp_str, buf, &size);

143
  for (size_t i = 0; i + 1 < size; i++)
144 145 146
    if (buf[i] == 'a')
      buf[i] = 'b';

147
  return env->make_string (env, buf, size - 1);
148 149 150
}


151
/* Embedded pointers in lisp objects.  */
152

153
/* C struct (pointer to) that will be embedded.  */
154 155 156 157 158 159
struct super_struct
{
  int amazing_int;
  char large_unused_buffer[512];
};

160 161 162
/* Associated finalizer.  */
static void
finalizer (void *p)
163 164 165 166 167
{
  if (p)
    free (p);
}

168 169 170 171 172
/* Return a new user-pointer to a super_struct, with amazing_int set
   to the passed parameter.  */
static emacs_value
Fmod_test_userptr_make (emacs_env *env, int nargs, emacs_value args[],
			void *data)
173
{
174
  struct super_struct *p = calloc (1, sizeof *p);
175
  p->amazing_int = env->extract_integer (env, args[0]);
176
  return env->make_user_ptr (env, free, p);
177 178
}

179 180 181
/* Return the amazing_int of a passed 'user-pointer to a super_struct'.  */
static emacs_value
Fmod_test_userptr_get (emacs_env *env, int nargs, emacs_value args[], void *data)
182 183 184 185 186 187
{
  struct super_struct *p = env->get_user_ptr (env, args[0]);
  return env->make_integer (env, p->amazing_int);
}


188 189 190
/* Fill vector in args[0] with value in args[1].  */
static emacs_value
Fmod_test_vector_fill (emacs_env *env, int nargs, emacs_value args[], void *data)
191 192 193
{
  emacs_value vec = args[0];
  emacs_value val = args[1];
Paul Eggert's avatar
Paul Eggert committed
194
  size_t size = env->vec_size (env, vec);
195
  for (size_t i = 0; i < size; i++)
196 197 198 199 200
    env->vec_set (env, vec, i, val);
  return env->intern (env, "t");
}


201 202 203 204
/* Return whether all elements of vector in args[0] are 'eq' to value
   in args[1].  */
static emacs_value
Fmod_test_vector_eq (emacs_env *env, int nargs, emacs_value args[], void *data)
205 206 207
{
  emacs_value vec = args[0];
  emacs_value val = args[1];
Paul Eggert's avatar
Paul Eggert committed
208
  size_t size = env->vec_size (env, vec);
209
  for (size_t i = 0; i < size; i++)
210 211 212 213 214 215
    if (!env->eq (env, env->vec_get (env, vec, i), val))
        return env->intern (env, "nil");
  return env->intern (env, "t");
}


216
/* Lisp utilities for easier readability (simple wrappers).  */
217

218 219 220
/* Provide FEATURE to Emacs.  */
static void
provide (emacs_env *env, const char *feature)
221 222 223 224 225 226 227 228
{
  emacs_value Qfeat = env->intern (env, feature);
  emacs_value Qprovide = env->intern (env, "provide");
  emacs_value args[] = { Qfeat };

  env->funcall (env, Qprovide, 1, args);
}

229 230 231
/* Bind NAME to FUN.  */
static void
bind_function (emacs_env *env, const char *name, emacs_value Sfun)
232 233 234 235 236 237 238 239
{
  emacs_value Qfset = env->intern (env, "fset");
  emacs_value Qsym = env->intern (env, name);
  emacs_value args[] = { Qsym, Sfun };

  env->funcall (env, Qfset, 2, args);
}

240 241 242
/* Module init function.  */
int
emacs_module_init (struct emacs_runtime *ert)
243 244 245 246
{
  emacs_env *env = ert->get_environment (ert);

#define DEFUN(lsym, csym, amin, amax, doc, data) \
247 248
  bind_function (env, lsym, \
		 env->make_function (env, amin, amax, csym, doc, data))
249 250 251 252 253

  DEFUN ("mod-test-return-t", Fmod_test_return_t, 1, 1, NULL, NULL);
  DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B", NULL);
  DEFUN ("mod-test-signal", Fmod_test_signal, 0, 0, NULL, NULL);
  DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL);
254 255
  DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall,
	 1, 1, NULL, NULL);
256 257 258 259 260 261 262 263 264 265 266 267
  DEFUN ("mod-test-globref-make", Fmod_test_globref_make, 0, 0, NULL, NULL);
  DEFUN ("mod-test-string-a-to-b", Fmod_test_string_a_to_b, 1, 1, NULL, NULL);
  DEFUN ("mod-test-userptr-make", Fmod_test_userptr_make, 1, 1, NULL, NULL);
  DEFUN ("mod-test-userptr-get", Fmod_test_userptr_get, 1, 1, NULL, NULL);
  DEFUN ("mod-test-vector-fill", Fmod_test_vector_fill, 2, 2, NULL, NULL);
  DEFUN ("mod-test-vector-eq", Fmod_test_vector_eq, 2, 2, NULL, NULL);

#undef DEFUN

  provide (env, "mod-test");
  return 0;
}