root/test/src/emacs-module-resources/mod-test.c

DEFINITIONS

1. Fmod_test_return_t
2. sum
3. Fmod_test_sum
4. Fmod_test_signal
5. Fmod_test_throw
6. Fmod_test_non_local_exit_funcall
7. Fmod_test_globref_make
8. Fmod_test_globref_free
9. Fmod_test_globref_invalid_free
10. Fmod_test_globref_reordered
11. Fmod_test_string_a_to_b
12. Fmod_test_return_unibyte
13. Fmod_test_userptr_make
14. Fmod_test_userptr_get
15. Fmod_test_vector_fill
16. Fmod_test_vector_eq
17. Fmod_test_invalid_store
18. Fmod_test_invalid_load
19. Fmod_test_invalid_store_copy
20. invalid_finalizer
21. Fmod_test_invalid_finalizer
22. signal_system_error
23. signal_errno
24. timespec_le
25. Fmod_test_sleep_until
26. Fmod_test_add_nanosecond
27. signal_error
28. memory_full
29. extract_big_integer
30. make_big_integer
31. Fmod_test_nanoseconds
32. Fmod_test_double
33. finalizer
34. Fmod_test_make_function_with_finalizer
35. Fmod_test_function_finalizer_calls
36. sleep_for_half_second
37. write_to_pipe
38. Fmod_test_async_pipe
39. Fmod_test_identity
40. Fmod_test_funcall
41. Fmod_test_make_string
42. provide
43. bind_function
44. emacs_module_init

     1 /* Test GNU Emacs modules.
     2 
     3 Copyright 2015-2023 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 (at
    10 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 <https://www.gnu.org/licenses/>.  */
    19 
    20 #include "config.h"
    21 
    22 #undef NDEBUG
    23 #include <assert.h>
    24 
    25 #include <errno.h>
    26 #include <limits.h>
    27 #include <stdint.h>
    28 #include <stdio.h>
    29 #include <stdlib.h>
    30 #include <string.h>
    31 #include <time.h>
    32 
    33 #ifdef WINDOWSNT
    34 /* Cannot include <process.h> because of the local header by the same
    35    name, sigh.  */
    36 uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *);
    37 # if !defined __x86_64__
    38 #  define ALIGN_STACK __attribute__((force_align_arg_pointer))
    39 # endif
    40 # include <windows.h>   /* for Sleep */
    41 #else  /* !WINDOWSNT */
    42 # include <pthread.h>
    43 # include <unistd.h>
    44 #endif
    45 
    46 #include <gmp.h>
    47 #include <emacs-module.h>
    48 
    49 int plugin_is_GPL_compatible;
    50 
    51 #if INTPTR_MAX <= 0
    52 # error "INTPTR_MAX misconfigured"
    53 #elif INTPTR_MAX <= INT_MAX || INTPTR_MAX <= LONG_MAX
    54 # define pT "ld"
    55 # define pZ "lu"
    56 # define T_TYPE long
    57 # define Z_TYPE unsigned long
    58 #elif INTPTR_MAX <= INT64_MAX
    59 # ifdef __MINGW32__
    60 #  define pT "lld"
    61 #  define pZ "llu"
    62 #  define T_TYPE long long
    63 #  define Z_TYPE unsigned long long
    64 # else
    65 #  define pT "ld"
    66 #  define pZ "lu"
    67 #  define T_TYPE long
    68 #  define Z_TYPE unsigned long
    69 # endif
    70 #else
    71 # error "INTPTR_MAX too large"
    72 #endif
    73 
    74 /* Always return symbol 't'.  */
    75 static emacs_value
    76 Fmod_test_return_t (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
    77                     void *data)
    78 {
    79   return env->intern (env, "t");
    80 }
    81 
    82 /* Expose simple sum function.  */
    83 static intmax_t
    84 sum (intmax_t a, intmax_t b)
    85 {
    86   return a + b;
    87 }
    88 
    89 static emacs_value
    90 Fmod_test_sum (emacs_env *env, ptrdiff_t nargs, emacs_value args[], void *data)
    91 {
    92   assert (nargs == 2);
    93   assert ((uintptr_t) data == 0x1234);
    94 
    95   intmax_t a = env->extract_integer (env, args[0]);
    96   intmax_t b = env->extract_integer (env, args[1]);
    97 
    98   intmax_t r = sum (a, b);
    99 
   100   return env->make_integer (env, r);
   101 }
   102 
   103 
   104 /* Signal '(error 56).  */
   105 static emacs_value
   106 Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   107                   void *data)
   108 {
   109   assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
   110   env->non_local_exit_signal (env, env->intern (env, "error"),
   111                               env->make_integer (env, 56));
   112   return NULL;
   113 }
   114 
   115 
   116 /* Throw '(tag 65).  */
   117 static emacs_value
   118 Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   119                  void *data)
   120 {
   121   assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
   122   env->non_local_exit_throw (env, env->intern (env, "tag"),
   123                              env->make_integer (env, 65));
   124   return NULL;
   125 }
   126 
   127 
   128 /* Call argument function, catch all non-local exists and return
   129    either normal result or a list describing the non-local exit.  */
   130 static emacs_value
   131 Fmod_test_non_local_exit_funcall (emacs_env *env, ptrdiff_t nargs,
   132                                   emacs_value args[], void *data)
   133 {
   134   assert (nargs == 1);
   135   emacs_value result = env->funcall (env, args[0], 0, NULL);
   136   emacs_value non_local_exit_symbol, non_local_exit_data;
   137   enum emacs_funcall_exit code
   138     = env->non_local_exit_get (env, &non_local_exit_symbol,
   139                                &non_local_exit_data);
   140   switch (code)
   141     {
   142     case emacs_funcall_exit_return:
   143       return result;
   144     case emacs_funcall_exit_signal:
   145       {
   146         env->non_local_exit_clear (env);
   147         emacs_value Flist = env->intern (env, "list");
   148         emacs_value list_args[] = {env->intern (env, "signal"),
   149                                    non_local_exit_symbol, non_local_exit_data};
   150         return env->funcall (env, Flist, 3, list_args);
   151       }
   152     case emacs_funcall_exit_throw:
   153       {
   154         env->non_local_exit_clear (env);
   155         emacs_value Flist = env->intern (env, "list");
   156         emacs_value list_args[] = {env->intern (env, "throw"),
   157                                    non_local_exit_symbol, non_local_exit_data};
   158         return env->funcall (env, Flist, 3, list_args);
   159       }
   160     }
   161 
   162   /* Never reached.  */
   163   return env->intern (env, "nil");;
   164 }
   165 
   166 
   167 /* Return a global reference.  */
   168 static emacs_value
   169 Fmod_test_globref_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   170                         void *data)
   171 {
   172   /* Make a big string and make it global.  */
   173   char str[26 * 100];
   174   for (int i = 0; i < sizeof str; i++)
   175     str[i] = 'a' + (i % 26);
   176 
   177   /* We don't need to null-terminate str.  */
   178   emacs_value lisp_str = env->make_string (env, str, sizeof str);
   179   return env->make_global_ref (env, lisp_str);
   180 }
   181 
   182 /* Create a few global references from arguments and free them.  */
   183 static emacs_value
   184 Fmod_test_globref_free (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   185                         void *data)
   186 {
   187   emacs_value refs[10];
   188   for (int i = 0; i < 10; i++)
   189     {
   190       refs[i] = env->make_global_ref (env, args[i % nargs]);
   191     }
   192   for (int i = 0; i < 10; i++)
   193     {
   194       env->free_global_ref (env, refs[i]);
   195     }
   196   return env->intern (env, "ok");
   197 }
   198 
   199 /* Treat a local reference as global and free it.  Module assertions
   200    should detect this case even if a global reference representing the
   201    same object also exists.  */
   202 
   203 static emacs_value
   204 Fmod_test_globref_invalid_free (emacs_env *env, ptrdiff_t nargs,
   205                                 emacs_value *args, void *data)
   206 {
   207   emacs_value local = env->make_integer (env, 9876);
   208   env->make_global_ref (env, local);
   209   env->free_global_ref (env, local);  /* Not allowed. */
   210   return env->intern (env, "nil");
   211 }
   212 
   213 /* Allocate and free global references in a different order.  */
   214 
   215 static emacs_value
   216 Fmod_test_globref_reordered (emacs_env *env, ptrdiff_t nargs,
   217                                 emacs_value *args, void *data)
   218 {
   219   emacs_value booleans[2] = {
   220     env->intern (env, "nil"),
   221     env->intern (env, "t"),
   222   };
   223   emacs_value local = env->intern (env, "foo");
   224   emacs_value globals[4] = {
   225     env->make_global_ref (env, local),
   226     env->make_global_ref (env, local),
   227     env->make_global_ref (env, env->intern (env, "foo")),
   228     env->make_global_ref (env, env->intern (env, "bar")),
   229   };
   230   emacs_value elements[4];
   231   for (int i = 0; i < 4; ++i)
   232     elements[i] = booleans[env->eq (env, globals[i], local)];
   233   emacs_value ret = env->funcall (env, env->intern (env, "list"), 4, elements);
   234   env->free_global_ref (env, globals[2]);
   235   env->free_global_ref (env, globals[1]);
   236   env->free_global_ref (env, globals[3]);
   237   env->free_global_ref (env, globals[0]);
   238   return ret;
   239 }
   240 
   241 
   242 /* Return a copy of the argument string where every 'a' is replaced
   243    with 'b'.  */
   244 static emacs_value
   245 Fmod_test_string_a_to_b (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   246                          void *data)
   247 {
   248   emacs_value lisp_str = args[0];
   249   ptrdiff_t size = 0;
   250   char * buf = NULL;
   251 
   252   env->copy_string_contents (env, lisp_str, buf, &size);
   253   buf = malloc (size);
   254   env->copy_string_contents (env, lisp_str, buf, &size);
   255 
   256   for (ptrdiff_t i = 0; i + 1 < size; i++)
   257     if (buf[i] == 'a')
   258       buf[i] = 'b';
   259 
   260   emacs_value ret = env->make_string (env, buf, size - 1);
   261   free (buf);
   262   return ret;
   263 }
   264 
   265 
   266 /* Return a unibyte string.  */
   267 static emacs_value
   268 Fmod_test_return_unibyte (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   269                           void *data)
   270 {
   271   const char *string = "foo\x00zot";
   272   return env->make_unibyte_string (env, string, 7);
   273 }
   274 
   275 
   276 /* Embedded pointers in lisp objects.  */
   277 
   278 /* C struct (pointer to) that will be embedded.  */
   279 struct super_struct
   280 {
   281   int amazing_int;
   282   char large_unused_buffer[512];
   283 };
   284 
   285 static void signal_errno (emacs_env *, char const *);
   286 
   287 /* Return a new user-pointer to a super_struct, with amazing_int set
   288    to the passed parameter.  */
   289 static emacs_value
   290 Fmod_test_userptr_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   291                         void *data)
   292 {
   293   struct super_struct *p = calloc (1, sizeof *p);
   294   if (!p)
   295     {
   296       signal_errno (env, "calloc");
   297       return NULL;
   298     }
   299   p->amazing_int = env->extract_integer (env, args[0]);
   300   return env->make_user_ptr (env, free, p);
   301 }
   302 
   303 /* Return the amazing_int of a passed 'user-pointer to a super_struct'.  */
   304 static emacs_value
   305 Fmod_test_userptr_get (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   306                        void *data)
   307 {
   308   struct super_struct *p = env->get_user_ptr (env, args[0]);
   309   return env->make_integer (env, p->amazing_int);
   310 }
   311 
   312 
   313 /* Fill vector in args[0] with value in args[1].  */
   314 static emacs_value
   315 Fmod_test_vector_fill (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   316                        void *data)
   317 {
   318   emacs_value vec = args[0];
   319   emacs_value val = args[1];
   320   ptrdiff_t size = env->vec_size (env, vec);
   321   for (ptrdiff_t i = 0; i < size; i++)
   322     env->vec_set (env, vec, i, val);
   323   return env->intern (env, "t");
   324 }
   325 
   326 
   327 /* Return whether all elements of vector in args[0] are 'eq' to value
   328    in args[1].  */
   329 static emacs_value
   330 Fmod_test_vector_eq (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
   331                      void *data)
   332 {
   333   emacs_value vec = args[0];
   334   emacs_value val = args[1];
   335   ptrdiff_t size = env->vec_size (env, vec);
   336   for (ptrdiff_t i = 0; i < size; i++)
   337     if (!env->eq (env, env->vec_get (env, vec, i), val))
   338         return env->intern (env, "nil");
   339   return env->intern (env, "t");
   340 }
   341 
   342 static emacs_value invalid_stored_value;
   343 
   344 /* The next two functions perform a possibly-invalid operation: they
   345    store a value in a static variable and load it.  This causes
   346    undefined behavior if the environment that the value was created
   347    from is no longer live.  The module assertions check for this
   348    error.  */
   349 
   350 static emacs_value
   351 Fmod_test_invalid_store (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   352                          void *data)
   353 {
   354   return invalid_stored_value = env->make_integer (env, 123);
   355 }
   356 
   357 static emacs_value
   358 Fmod_test_invalid_load (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   359                         void *data)
   360 {
   361   return invalid_stored_value;
   362 }
   363 
   364 /* The next function works in conjunction with the two previous ones.
   365    It stows away a copy of the object created by
   366    `Fmod_test_invalid_store' in a global reference.  Module assertions
   367    should still detect the invalid load of the local reference.  */
   368 
   369 static emacs_value global_copy_of_invalid_stored_value;
   370 
   371 static emacs_value
   372 Fmod_test_invalid_store_copy (emacs_env *env, ptrdiff_t nargs,
   373                               emacs_value *args, void *data)
   374 {
   375   emacs_value local = Fmod_test_invalid_store (env, 0, NULL, NULL);
   376   return global_copy_of_invalid_stored_value
   377          = env->make_global_ref (env, local);
   378 }
   379 
   380 /* An invalid finalizer: Finalizers are run during garbage collection,
   381    where Lisp code can't be executed.  -module-assertions tests for
   382    this case.  */
   383 
   384 static emacs_env *current_env;
   385 
   386 static void
   387 invalid_finalizer (void *ptr)
   388 {
   389   current_env->intern (current_env, "nil");
   390 }
   391 
   392 static emacs_value
   393 Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   394                              void *data)
   395 {
   396   current_env = env;
   397   env->make_user_ptr (env, invalid_finalizer, NULL);
   398   return env->intern (env, "nil");
   399 }
   400 
   401 static void
   402 signal_system_error (emacs_env *env, int error, const char *function)
   403 {
   404   const char *message = strerror (error);
   405   emacs_value message_value = env->make_string (env, message, strlen (message));
   406   emacs_value symbol = env->intern (env, "file-error");
   407   emacs_value elements[2]
   408     = {env->make_string (env, function, strlen (function)), message_value};
   409   emacs_value data = env->funcall (env, env->intern (env, "list"), 2, elements);
   410   env->non_local_exit_signal (env, symbol, data);
   411 }
   412 
   413 static void
   414 signal_errno (emacs_env *env, const char *function)
   415 {
   416   signal_system_error (env, errno, function);
   417 }
   418 
   419 #ifdef CLOCK_REALTIME
   420 
   421 /* Whether A <= B.  */
   422 static bool
   423 timespec_le (struct timespec a, struct timespec b)
   424 {
   425   return (a.tv_sec < b.tv_sec
   426           || (a.tv_sec == b.tv_sec && a.tv_nsec <= b.tv_nsec));
   427 }
   428 
   429 /* A long-running operation that occasionally calls `should_quit' or
   430    `process_input'.  */
   431 
   432 static emacs_value
   433 Fmod_test_sleep_until (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   434                        void *data)
   435 {
   436   assert (nargs == 2);
   437   const struct timespec until = env->extract_time (env, args[0]);
   438   if (env->non_local_exit_check (env))
   439     return NULL;
   440   const bool process_input = env->is_not_nil (env, args[1]);
   441   const struct timespec amount = { .tv_nsec = 10000000 };
   442   while (true)
   443     {
   444       struct timespec now;
   445       if (clock_gettime (CLOCK_REALTIME, &now) != 0)
   446         return NULL;
   447       if (timespec_le (until, now))
   448         break;
   449       if (nanosleep (&amount, NULL) && errno != EINTR)
   450         {
   451           signal_errno (env, "nanosleep");
   452           return NULL;
   453         }
   454       if ((process_input
   455            && env->process_input (env) == emacs_process_input_quit)
   456           || env->should_quit (env))
   457         return NULL;
   458     }
   459   return env->intern (env, "finished");
   460 }
   461 #endif
   462 
   463 static emacs_value
   464 Fmod_test_add_nanosecond (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   465                           void *data)
   466 {
   467   assert (nargs == 1);
   468   struct timespec time = env->extract_time (env, args[0]);
   469   assert (time.tv_nsec >= 0);
   470   assert (time.tv_nsec < 2000000000);  /* possible leap second */
   471   time.tv_nsec++;
   472   return env->make_time (env, time);
   473 }
   474 
   475 static void
   476 signal_error (emacs_env *env, const char *message)
   477 {
   478   emacs_value data = env->make_string (env, message, strlen (message));
   479   env->non_local_exit_signal (env, env->intern (env, "error"),
   480                               env->funcall (env, env->intern (env, "list"), 1,
   481                                             &data));
   482 }
   483 
   484 static void
   485 memory_full (emacs_env *env)
   486 {
   487   signal_error (env, "Memory exhausted");
   488 }
   489 
   490 enum
   491 {
   492   max_count = ((SIZE_MAX < PTRDIFF_MAX ? SIZE_MAX : PTRDIFF_MAX)
   493                / sizeof (emacs_limb_t))
   494 };
   495 
   496 static bool
   497 extract_big_integer (emacs_env *env, emacs_value arg, mpz_t result)
   498 {
   499   int sign;
   500   ptrdiff_t count;
   501   bool success = env->extract_big_integer (env, arg, &sign, &count, NULL);
   502   if (!success)
   503     return false;
   504   if (sign == 0)
   505     {
   506       mpz_set_ui (result, 0);
   507       return true;
   508     }
   509   enum { order = -1, size = sizeof (emacs_limb_t), endian = 0, nails = 0 };
   510   assert (0 < count && count <= max_count);
   511   emacs_limb_t *magnitude = malloc (count * size);
   512   if (magnitude == NULL)
   513     {
   514       memory_full (env);
   515       return false;
   516     }
   517   success = env->extract_big_integer (env, arg, NULL, &count, magnitude);
   518   assert (success);
   519   mpz_import (result, count, order, size, endian, nails, magnitude);
   520   free (magnitude);
   521   if (sign < 0)
   522     mpz_neg (result, result);
   523   return true;
   524 }
   525 
   526 static emacs_value
   527 make_big_integer (emacs_env *env, const mpz_t value)
   528 {
   529   if (mpz_sgn (value) == 0)
   530     return env->make_integer (env, 0);
   531   /* See
   532      https://gmplib.org/manual/Integer-Import-and-Export.html#index-Export. */
   533   enum
   534   {
   535     order = -1,
   536     size = sizeof (emacs_limb_t),
   537     endian = 0,
   538     nails = 0,
   539     numb = 8 * size - nails
   540   };
   541   size_t count = (mpz_sizeinbase (value, 2) + numb - 1) / numb;
   542   if (max_count < count)
   543     {
   544       memory_full (env);
   545       return NULL;
   546     }
   547   emacs_limb_t *magnitude = malloc (count * size);
   548   if (magnitude == NULL)
   549     {
   550       memory_full (env);
   551       return NULL;
   552     }
   553   size_t written;
   554   mpz_export (magnitude, &written, order, size, endian, nails, value);
   555   assert (written == count);
   556   assert (count <= PTRDIFF_MAX);
   557   emacs_value result = env->make_big_integer (env, mpz_sgn (value),
   558                                               (ptrdiff_t) count, magnitude);
   559   free (magnitude);
   560   return result;
   561 }
   562 
   563 #ifdef CLOCK_REALTIME
   564 static emacs_value
   565 Fmod_test_nanoseconds (emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) {
   566   assert (nargs == 1);
   567   struct timespec time = env->extract_time (env, args[0]);
   568   mpz_t nanoseconds;
   569   assert (LONG_MIN <= time.tv_sec && time.tv_sec <= LONG_MAX);
   570   mpz_init_set_si (nanoseconds, time.tv_sec);
   571   mpz_mul_ui (nanoseconds, nanoseconds, 1000000000);
   572   assert (0 <= time.tv_nsec && time.tv_nsec <= ULONG_MAX);
   573   mpz_add_ui (nanoseconds, nanoseconds, time.tv_nsec);
   574   emacs_value result = make_big_integer (env, nanoseconds);
   575   mpz_clear (nanoseconds);
   576   return result;
   577 }
   578 #endif
   579 
   580 static emacs_value
   581 Fmod_test_double (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   582                   void *data)
   583 {
   584   assert (nargs == 1);
   585   emacs_value arg = args[0];
   586   mpz_t value;
   587   mpz_init (value);
   588   extract_big_integer (env, arg, value);
   589   mpz_mul_ui (value, value, 2);
   590   emacs_value result = make_big_integer (env, value);
   591   mpz_clear (value);
   592   return result;
   593 }
   594 
   595 static int function_data;
   596 static int finalizer_calls_with_correct_data;
   597 static int finalizer_calls_with_incorrect_data;
   598 
   599 static void
   600 finalizer (void *data)
   601 {
   602   if (data == &function_data)
   603     ++finalizer_calls_with_correct_data;
   604   else
   605     ++finalizer_calls_with_incorrect_data;
   606 }
   607 
   608 static emacs_value
   609 Fmod_test_make_function_with_finalizer (emacs_env *env, ptrdiff_t nargs,
   610                                         emacs_value *args, void *data)
   611 {
   612   emacs_value fun
   613     = env->make_function (env, 2, 2, Fmod_test_sum, NULL, &function_data);
   614   env->set_function_finalizer (env, fun, finalizer);
   615   if (env->get_function_finalizer (env, fun) != finalizer)
   616     signal_error (env, "Invalid finalizer");
   617   return fun;
   618 }
   619 
   620 static emacs_value
   621 Fmod_test_function_finalizer_calls (emacs_env *env, ptrdiff_t nargs,
   622                                     emacs_value *args, void *data)
   623 {
   624   emacs_value Flist = env->intern (env, "list");
   625   emacs_value list_args[]
   626     = {env->make_integer (env, finalizer_calls_with_correct_data),
   627        env->make_integer (env, finalizer_calls_with_incorrect_data)};
   628   return env->funcall (env, Flist, 2, list_args);
   629 }
   630 
   631 static void
   632 sleep_for_half_second (void)
   633 {
   634   /* mingw.org's MinGW has nanosleep, but MinGW64 doesn't.  */
   635 #ifdef WINDOWSNT
   636   Sleep (500);
   637 #else
   638   const struct timespec sleep = { .tv_nsec = 500000000 };
   639   if (nanosleep (&sleep, NULL) != 0)
   640     perror ("nanosleep");
   641 #endif
   642 }
   643 
   644 #ifdef WINDOWSNT
   645 static void ALIGN_STACK
   646 #else
   647 static void *
   648 #endif
   649 write_to_pipe (void *arg)
   650 {
   651   /* We sleep a bit to test that writing to a pipe is indeed possible
   652      if no environment is active. */
   653   sleep_for_half_second ();
   654   FILE *stream = arg;
   655   /* The string below should be identical to the one we compare with
   656      in emacs-module-tests.el:module/async-pipe.  */
   657   if (fputs ("data from thread", stream) < 0)
   658     perror ("fputs");
   659   if (fclose (stream) != 0)
   660     perror ("close");
   661 #ifndef WINDOWSNT
   662   return NULL;
   663 #endif
   664 }
   665 
   666 static emacs_value
   667 Fmod_test_async_pipe (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   668                       void *data)
   669 {
   670   assert (nargs == 1);
   671   int fd = env->open_channel (env, args[0]);
   672   if (env->non_local_exit_check (env) != emacs_funcall_exit_return)
   673     return NULL;
   674   FILE *stream = fdopen (fd, "w");
   675   if (stream == NULL)
   676     {
   677       signal_errno (env, "fdopen");
   678       return NULL;
   679     }
   680 #ifdef WINDOWSNT
   681   uintptr_t thd = _beginthread (write_to_pipe, 0, stream);
   682   int error = (thd == (uintptr_t)-1L) ? errno : 0;
   683 #else  /* !WINDOWSNT */
   684   pthread_t thread;
   685   int error
   686     = pthread_create (&thread, NULL, write_to_pipe, stream);
   687 #endif
   688   if (error != 0)
   689     {
   690       signal_system_error (env, error, "thread create");
   691       if (fclose (stream) != 0)
   692         perror ("fclose");
   693       return NULL;
   694     }
   695   return env->intern (env, "nil");
   696 }
   697 
   698 static emacs_value
   699 Fmod_test_identity (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   700                     void *data)
   701 {
   702   assert (nargs == 1);
   703   return args[0];
   704 }
   705 
   706 static emacs_value
   707 Fmod_test_funcall (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   708                    void *data)
   709 {
   710   assert (0 < nargs);
   711   return env->funcall (env, args[0], nargs - 1, args + 1);
   712 }
   713 
   714 static emacs_value
   715 Fmod_test_make_string (emacs_env *env, ptrdiff_t nargs,
   716                        emacs_value *args, void *data)
   717 {
   718   assert (nargs == 2);
   719   intmax_t length_arg = env->extract_integer (env, args[0]);
   720   if (env->non_local_exit_check (env) != emacs_funcall_exit_return)
   721     return args[0];
   722   if (length_arg < 0 || SIZE_MAX < length_arg)
   723     {
   724       signal_error (env, "Invalid string length");
   725       return args[0];
   726     }
   727   size_t length = (size_t) length_arg;
   728   bool multibyte = env->is_not_nil (env, args[1]);
   729   char *buffer = length == 0 ? NULL : malloc (length);
   730   if (buffer == NULL && length != 0)
   731     {
   732       memory_full (env);
   733       return args[0];
   734     }
   735   memset (buffer, 'a', length);
   736   emacs_value ret = multibyte ? env->make_string (env, buffer, length)
   737                               : env->make_unibyte_string (env, buffer, length);
   738   free (buffer);
   739   return ret;
   740 }
   741 
   742 /* Lisp utilities for easier readability (simple wrappers).  */
   743 
   744 /* Provide FEATURE to Emacs.  */
   745 static void
   746 provide (emacs_env *env, const char *feature)
   747 {
   748   emacs_value Qfeat = env->intern (env, feature);
   749   emacs_value Qprovide = env->intern (env, "provide");
   750   emacs_value args[] = { Qfeat };
   751 
   752   env->funcall (env, Qprovide, 1, args);
   753 }
   754 
   755 /* Bind NAME to FUN.  */
   756 static void
   757 bind_function (emacs_env *env, const char *name, emacs_value Sfun)
   758 {
   759   emacs_value Qdefalias = env->intern (env, "defalias");
   760   emacs_value Qsym = env->intern (env, name);
   761   emacs_value args[] = { Qsym, Sfun };
   762 
   763   env->funcall (env, Qdefalias, 2, args);
   764 }
   765 
   766 /* Module init function.  */
   767 int
   768 emacs_module_init (struct emacs_runtime *ert)
   769 {
   770   /* These smoke tests don't use _Static_assert because too many
   771      compilers lack support for _Static_assert.  */
   772   assert (0 < EMACS_LIMB_MAX);
   773   assert (1000000000 <= ULONG_MAX);
   774 
   775   /* Check that EMACS_MAJOR_VERSION is defined and an integral
   776      constant.  */
   777   char dummy[EMACS_MAJOR_VERSION];
   778   assert (27 <= sizeof dummy);
   779 
   780   if (ert->size < sizeof *ert)
   781     {
   782       fprintf (stderr, "Runtime size of runtime structure (%"pT" bytes) "
   783                "smaller than compile-time size (%"pZ" bytes)",
   784                (T_TYPE) ert->size, (Z_TYPE) sizeof (*ert));
   785       return 1;
   786     }
   787 
   788   emacs_env *env = ert->get_environment (ert);
   789 
   790   if (env->size < sizeof *env)
   791     {
   792       fprintf (stderr, "Runtime size of environment structure (%"pT" bytes) "
   793                "smaller than compile-time size (%"pZ" bytes)",
   794                (T_TYPE) env->size, (Z_TYPE) sizeof (*env));
   795       return 2;
   796     }
   797 
   798 #define DEFUN(lsym, csym, amin, amax, doc, data) \
   799   bind_function (env, lsym, \
   800                  env->make_function (env, amin, amax, csym, doc, data))
   801 
   802   DEFUN ("mod-test-return-t", Fmod_test_return_t, 1, 1, NULL, NULL);
   803   DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn a b)",
   804          (void *) (uintptr_t) 0x1234);
   805   DEFUN ("mod-test-signal", Fmod_test_signal, 0, 0, NULL, NULL);
   806   DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL);
   807   DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall,
   808          1, 1, NULL, NULL);
   809   DEFUN ("mod-test-globref-make", Fmod_test_globref_make, 0, 0, NULL, NULL);
   810   DEFUN ("mod-test-globref-free", Fmod_test_globref_free, 4, 4, NULL, NULL);
   811   DEFUN ("mod-test-globref-invalid-free", Fmod_test_globref_invalid_free, 0, 0,
   812          NULL, NULL);
   813   DEFUN ("mod-test-globref-reordered", Fmod_test_globref_reordered, 0, 0, NULL,
   814          NULL);
   815   DEFUN ("mod-test-string-a-to-b", Fmod_test_string_a_to_b, 1, 1, NULL, NULL);
   816   DEFUN ("mod-test-return-unibyte", Fmod_test_return_unibyte, 0, 0, NULL, NULL);
   817   DEFUN ("mod-test-userptr-make", Fmod_test_userptr_make, 1, 1, NULL, NULL);
   818   DEFUN ("mod-test-userptr-get", Fmod_test_userptr_get, 1, 1, NULL, NULL);
   819   DEFUN ("mod-test-vector-fill", Fmod_test_vector_fill, 2, 2, NULL, NULL);
   820   DEFUN ("mod-test-vector-eq", Fmod_test_vector_eq, 2, 2, NULL, NULL);
   821   DEFUN ("mod-test-invalid-store", Fmod_test_invalid_store, 0, 0, NULL, NULL);
   822   DEFUN ("mod-test-invalid-store-copy", Fmod_test_invalid_store_copy, 0, 0,
   823          NULL, NULL);
   824   DEFUN ("mod-test-invalid-load", Fmod_test_invalid_load, 0, 0, NULL, NULL);
   825   DEFUN ("mod-test-invalid-finalizer", Fmod_test_invalid_finalizer, 0, 0,
   826          NULL, NULL);
   827 #ifdef CLOCK_REALTIME
   828   DEFUN ("mod-test-sleep-until", Fmod_test_sleep_until, 2, 2, NULL, NULL);
   829 #endif
   830   DEFUN ("mod-test-add-nanosecond", Fmod_test_add_nanosecond, 1, 1, NULL, NULL);
   831 #ifdef CLOCK_REALTIME
   832   DEFUN ("mod-test-nanoseconds", Fmod_test_nanoseconds, 1, 1, NULL, NULL);
   833 #endif
   834   DEFUN ("mod-test-double", Fmod_test_double, 1, 1, NULL, NULL);
   835   DEFUN ("mod-test-make-function-with-finalizer",
   836          Fmod_test_make_function_with_finalizer, 0, 0, NULL, NULL);
   837   DEFUN ("mod-test-function-finalizer-calls",
   838          Fmod_test_function_finalizer_calls, 0, 0, NULL, NULL);
   839   DEFUN ("mod-test-async-pipe", Fmod_test_async_pipe, 1, 1, NULL, NULL);
   840   DEFUN ("mod-test-funcall", Fmod_test_funcall, 1, emacs_variadic_function,
   841          NULL, NULL);
   842   DEFUN ("mod-test-make-string", Fmod_test_make_string, 2, 2, NULL, NULL);
   843 
   844 #undef DEFUN
   845 
   846   emacs_value constant_fn
   847     = env->make_function (env, 0, 0, Fmod_test_return_t, NULL, NULL);
   848   env->make_interactive (env, constant_fn, env->intern (env, "nil"));
   849   bind_function (env, "mod-test-return-t-int", constant_fn);
   850 
   851   emacs_value identity_fn
   852     = env->make_function (env, 1, 1, Fmod_test_identity, NULL, NULL);
   853   const char *interactive_spec = "i";
   854   env->make_interactive (env, identity_fn,
   855                          env->make_string (env, interactive_spec,
   856                                            strlen (interactive_spec)));
   857   bind_function (env, "mod-test-identity", identity_fn);
   858 
   859   /* We allocate lots of values to trigger bugs in the frame allocator during
   860      initialization.  */
   861   int count = 10000;  /* larger than value_frame_size in emacs-module.c */
   862   for (int i = 0; i < count; ++i)
   863     env->make_integer (env, i);
   864 
   865   provide (env, "mod-test");
   866   return 0;
   867 }