1 /* emacs-module.c - Module loading and runtime implementation
3 Copyright (C) 2015 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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.
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.
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/>. */
22 #include "emacs-module.h"
38 /* True if __attribute__ ((cleanup (...))) works, false otherwise. */
39 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
40 enum { module_has_cleanup
= true };
42 enum { module_has_cleanup
= false };
45 /* Handle to the main thread. Used to verify that modules call us in
49 static thrd_t main_thread
;
50 #elif defined HAVE_PTHREAD
52 static pthread_t main_thread
;
53 #elif defined WINDOWSNT
56 static DWORD main_thread
;
60 /* Private runtime and environment members. */
62 /* The private part of an environment stores the current non local exit state
63 and holds the `emacs_value' objects allocated during the lifetime
64 of the environment. */
65 struct emacs_env_private
67 enum emacs_funcall_exit pending_non_local_exit
;
69 /* Dedicated storage for non-local exit symbol and data so that
70 storage is always available for them, even in an out-of-memory
72 Lisp_Object non_local_exit_symbol
, non_local_exit_data
;
75 /* The private parts of an `emacs_runtime' object contain the initial
77 struct emacs_runtime_private
79 /* FIXME: Ideally, we would just define "struct emacs_runtime_private"
80 * as a synonym of "emacs_env", but I don't know how to do that in C. */
85 /* Forward declarations. */
87 struct module_fun_env
;
89 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*);
90 static Lisp_Object
value_to_lisp (emacs_value
);
91 static emacs_value
lisp_to_value (Lisp_Object
);
92 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*);
93 static void check_main_thread (void);
94 static void finalize_environment (struct emacs_env_private
*);
95 static void initialize_environment (emacs_env
*, struct emacs_env_private
*priv
);
96 static void module_args_out_of_range (emacs_env
*, Lisp_Object
, Lisp_Object
);
97 static void module_handle_signal (emacs_env
*, Lisp_Object
);
98 static void module_handle_throw (emacs_env
*, Lisp_Object
);
99 static void module_non_local_exit_signal_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
100 static void module_non_local_exit_throw_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
101 static void module_out_of_memory (emacs_env
*);
102 static void module_reset_handlerlist (const int *);
103 static void module_wrong_type (emacs_env
*, Lisp_Object
, Lisp_Object
);
105 /* We used to return NULL when emacs_value was a different type from
106 Lisp_Object, but nowadays we just use Qnil instead. */
107 static emacs_value module_nil
;
109 /* Convenience macros for non-local exit handling. */
111 /* Emacs uses setjmp and longjmp for non-local exits, but
112 module frames cannot be skipped because they are in general
113 not prepared for long jumps (e.g., the behavior in C++ is undefined
114 if objects with nontrivial destructors would be skipped).
115 Therefore, catch all non-local exits. There are two kinds of
116 non-local exits: `signal' and `throw'. The macros in this section
117 can be used to catch both. Use macros to avoid additional variants
118 of `internal_condition_case' etc., and to avoid worrying about
119 passing information to the handler functions. */
121 /* Place this macro at the beginning of a function returning a number
122 or a pointer to handle non-local exits. The function must have an
123 ENV parameter. The function will return the specified value if a
124 signal or throw is caught. */
125 // TODO: Have Fsignal check for CATCHER_ALL so we only have to install
127 #define MODULE_HANDLE_NONLOCAL_EXIT(retval) \
128 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
129 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
131 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
132 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
133 internal_handler_##handlertype, \
134 internal_cleanup_##handlertype)
136 /* It is very important that pushing the handler doesn't itself raise
137 a signal. Install the cleanup only after the handler has been
138 pushed. Use __attribute__ ((cleanup)) to avoid
139 non-local-exit-prone manual cleanup.
141 The do-while forces uses of the macro to be followed by a semicolon.
142 This macro cannot enclose its entire body inside a do-while, as the
143 code after the macro may longjmp back into the macro, which means
144 its local variable C must stay live in later code. */
146 // TODO: Make backtraces work if this macros is used.
148 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
149 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
151 struct handler *c = push_handler_nosignal (Qt, handlertype); \
154 module_out_of_memory (env); \
157 verify (module_has_cleanup); \
158 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
159 if (sys_setjmp (c->jmp)) \
161 (handlerfunc) (env, c->val); \
167 /* Function environments. */
169 /* A function environment is an auxiliary structure used by
170 `module_make_function' to store information about a module
171 function. It is stored in a save pointer and retrieved by
172 `internal--module-call'. Its members correspond to the arguments
173 given to `module_make_function'. */
175 struct module_fun_env
177 ptrdiff_t min_arity
, max_arity
;
183 /* Implementation of runtime and environment functions.
185 These should abide by the following rules:
187 1. The first argument should always be a pointer to emacs_env.
189 2. Each function should first call check_main_thread. Note that
190 this function is a no-op unless Emacs was built with
193 3. The very next thing each function should do is check that the
194 emacs_env object does not have a non-local exit indication set,
195 by calling module_non_local_exit_check. If that returns
196 anything but emacs_funcall_exit_return, the function should do
197 nothing and return immediately with an error indication, without
198 clobbering the existing error indication in emacs_env. This is
199 needed for correct reporting of Lisp errors to the Emacs Lisp
202 4. Any function that needs to call Emacs facilities, such as
203 encoding or decoding functions, or 'intern', or 'make_string',
204 should protect itself from signals and 'throw' in the called
205 Emacs functions, by placing the macro
206 MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
208 5. Do NOT use 'eassert' for checking validity of user code in the
209 module. Instead, make those checks part of the code, and if the
210 check fails, call 'module_non_local_exit_signal_1' or
211 'module_non_local_exit_throw_1' to report the error. This is
212 because using 'eassert' in these situations will abort Emacs
213 instead of reporting the error back to Lisp, and also because
214 'eassert' is compiled to nothing in the release version. */
216 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
217 environment functions. On error it will return its argument, which
218 should be a sentinel value. */
220 #define MODULE_FUNCTION_BEGIN(error_retval) \
221 check_main_thread (); \
222 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
223 return error_retval; \
224 MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
226 /* Catch signals and throws only if the code can actually signal or
227 throw. If checking is enabled, abort if the current thread is not
228 the Emacs main thread. */
231 module_get_environment (struct emacs_runtime
*ert
)
233 check_main_thread ();
234 return &ert
->private_members
->pub
;
237 /* To make global refs (GC-protected global values) keep a hash that
238 maps global Lisp objects to reference counts. */
241 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
243 MODULE_FUNCTION_BEGIN (module_nil
);
244 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
245 Lisp_Object new_obj
= value_to_lisp (ref
);
247 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
251 Lisp_Object value
= HASH_VALUE (h
, i
);
252 EMACS_INT refcount
= XFASTINT (value
) + 1;
253 if (refcount
> MOST_POSITIVE_FIXNUM
)
255 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
258 value
= make_natnum (refcount
);
259 set_hash_value_slot (h
, i
, value
);
263 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
266 return lisp_to_value (new_obj
);
270 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
272 /* TODO: This probably never signals. */
273 /* FIXME: Wait a minute. Shouldn't this function report an error if
274 the hash lookup fails? */
275 MODULE_FUNCTION_BEGIN ();
276 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
277 Lisp_Object obj
= value_to_lisp (ref
);
279 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
283 Lisp_Object value
= HASH_VALUE (h
, i
);
284 EMACS_INT refcount
= XFASTINT (value
) - 1;
287 value
= make_natnum (refcount
);
288 set_hash_value_slot (h
, i
, value
);
291 hash_remove_from_table (h
, value
);
295 static enum emacs_funcall_exit
296 module_non_local_exit_check (emacs_env
*env
)
298 check_main_thread ();
299 return env
->private_members
->pending_non_local_exit
;
303 module_non_local_exit_clear (emacs_env
*env
)
305 check_main_thread ();
306 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
309 static enum emacs_funcall_exit
310 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
312 check_main_thread ();
313 struct emacs_env_private
*p
= env
->private_members
;
314 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
316 *sym
= lisp_to_value (p
->non_local_exit_symbol
);
317 *data
= lisp_to_value (p
->non_local_exit_data
);
319 return p
->pending_non_local_exit
;
322 /* Like for `signal', DATA must be a list. */
324 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
326 check_main_thread ();
327 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
328 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
329 value_to_lisp (data
));
333 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
335 check_main_thread ();
336 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
337 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
338 value_to_lisp (value
));
341 /* A module function is lambda function that calls
342 `internal--module-call', passing the function pointer of the module
343 function along with the module emacs_env pointer as arguments.
345 (function (lambda (&rest arglist)
346 (internal--module-call envobj arglist))) */
349 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
350 emacs_subr subr
, const char *documentation
,
353 MODULE_FUNCTION_BEGIN (module_nil
);
355 if (! (0 <= min_arity
357 ? max_arity
== emacs_variadic_function
358 : min_arity
<= max_arity
)))
359 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
361 /* FIXME: This should be freed when envobj is GC'd. */
362 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
363 envptr
->min_arity
= min_arity
;
364 envptr
->max_arity
= max_arity
;
368 Lisp_Object envobj
= make_save_ptr (envptr
);
371 ? code_convert_string_norecord (build_unibyte_string (documentation
),
374 /* FIXME: Use a bytecompiled object, or even better a subr. */
375 Lisp_Object ret
= list4 (Qlambda
,
376 list2 (Qand_rest
, Qargs
),
379 list2 (Qfunction
, Qinternal_module_call
),
383 return lisp_to_value (ret
);
387 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
390 MODULE_FUNCTION_BEGIN (module_nil
);
392 /* Make a new Lisp_Object array starting with the function as the
393 first arg, because that's what Ffuncall takes. */
394 Lisp_Object
*newargs
;
396 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
397 newargs
[0] = value_to_lisp (fun
);
398 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
399 newargs
[1 + i
] = value_to_lisp (args
[i
]);
400 emacs_value result
= lisp_to_value (Ffuncall (nargs
+ 1, newargs
));
406 module_intern (emacs_env
*env
, const char *name
)
408 MODULE_FUNCTION_BEGIN (module_nil
);
409 return lisp_to_value (intern (name
));
413 module_type_of (emacs_env
*env
, emacs_value value
)
415 MODULE_FUNCTION_BEGIN (module_nil
);
416 return lisp_to_value (Ftype_of (value_to_lisp (value
)));
420 module_is_not_nil (emacs_env
*env
, emacs_value value
)
422 check_main_thread ();
423 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
425 return ! NILP (value_to_lisp (value
));
429 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
431 check_main_thread ();
432 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
434 return EQ (value_to_lisp (a
), value_to_lisp (b
));
438 module_extract_integer (emacs_env
*env
, emacs_value n
)
440 MODULE_FUNCTION_BEGIN (0);
441 Lisp_Object l
= value_to_lisp (n
);
444 module_wrong_type (env
, Qintegerp
, l
);
451 module_make_integer (emacs_env
*env
, intmax_t n
)
453 MODULE_FUNCTION_BEGIN (module_nil
);
454 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
456 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
459 return lisp_to_value (make_number (n
));
463 module_extract_float (emacs_env
*env
, emacs_value f
)
465 MODULE_FUNCTION_BEGIN (0);
466 Lisp_Object lisp
= value_to_lisp (f
);
469 module_wrong_type (env
, Qfloatp
, lisp
);
472 return XFLOAT_DATA (lisp
);
476 module_make_float (emacs_env
*env
, double d
)
478 MODULE_FUNCTION_BEGIN (module_nil
);
479 return lisp_to_value (make_float (d
));
483 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
486 MODULE_FUNCTION_BEGIN (false);
487 Lisp_Object lisp_str
= value_to_lisp (value
);
488 if (! STRINGP (lisp_str
))
490 module_wrong_type (env
, Qstringp
, lisp_str
);
494 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
495 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
496 if (raw_size
== PTRDIFF_MAX
)
498 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
501 ptrdiff_t required_buf_size
= raw_size
+ 1;
503 eassert (length
!= NULL
);
507 *length
= required_buf_size
;
511 eassert (*length
>= 0);
513 if (*length
< required_buf_size
)
515 *length
= required_buf_size
;
516 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, Qnil
);
520 *length
= required_buf_size
;
521 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
527 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
529 MODULE_FUNCTION_BEGIN (module_nil
);
530 if (length
> STRING_BYTES_BOUND
)
532 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
535 Lisp_Object lstr
= make_unibyte_string (str
, length
);
536 return lisp_to_value (code_convert_string_norecord (lstr
, Qutf_8
, false));
540 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
542 MODULE_FUNCTION_BEGIN (module_nil
);
543 return lisp_to_value (make_user_ptr (fin
, ptr
));
547 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
549 MODULE_FUNCTION_BEGIN (NULL
);
550 Lisp_Object lisp
= value_to_lisp (uptr
);
551 if (! USER_PTRP (lisp
))
553 module_wrong_type (env
, Quser_ptr
, lisp
);
556 return XUSER_PTR (lisp
)->p
;
560 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
562 // FIXME: This function should return bool because it can fail.
563 MODULE_FUNCTION_BEGIN ();
564 check_main_thread ();
565 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
567 Lisp_Object lisp
= value_to_lisp (uptr
);
568 if (! USER_PTRP (lisp
))
569 module_wrong_type (env
, Quser_ptr
, lisp
);
570 XUSER_PTR (lisp
)->p
= ptr
;
573 static emacs_finalizer_function
574 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
576 MODULE_FUNCTION_BEGIN (NULL
);
577 Lisp_Object lisp
= value_to_lisp (uptr
);
578 if (! USER_PTRP (lisp
))
580 module_wrong_type (env
, Quser_ptr
, lisp
);
583 return XUSER_PTR (lisp
)->finalizer
;
587 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
588 emacs_finalizer_function fin
)
590 // FIXME: This function should return bool because it can fail.
591 MODULE_FUNCTION_BEGIN ();
592 Lisp_Object lisp
= value_to_lisp (uptr
);
593 if (! USER_PTRP (lisp
))
594 module_wrong_type (env
, Quser_ptr
, lisp
);
595 XUSER_PTR (lisp
)->finalizer
= fin
;
599 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
601 // FIXME: This function should return bool because it can fail.
602 MODULE_FUNCTION_BEGIN ();
603 Lisp_Object lvec
= value_to_lisp (vec
);
604 if (! VECTORP (lvec
))
606 module_wrong_type (env
, Qvectorp
, lvec
);
609 if (! (0 <= i
&& i
< ASIZE (lvec
)))
611 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
612 module_args_out_of_range (env
, lvec
, make_number (i
));
614 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
617 ASET (lvec
, i
, value_to_lisp (val
));
621 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
623 MODULE_FUNCTION_BEGIN (module_nil
);
624 Lisp_Object lvec
= value_to_lisp (vec
);
625 if (! VECTORP (lvec
))
627 module_wrong_type (env
, Qvectorp
, lvec
);
630 if (! (0 <= i
&& i
< ASIZE (lvec
)))
632 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
633 module_args_out_of_range (env
, lvec
, make_number (i
));
635 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
638 return lisp_to_value (AREF (lvec
, i
));
642 module_vec_size (emacs_env
*env
, emacs_value vec
)
644 // FIXME: Return a sentinel value (e.g., -1) on error.
645 MODULE_FUNCTION_BEGIN (0);
646 Lisp_Object lvec
= value_to_lisp (vec
);
647 if (! VECTORP (lvec
))
649 module_wrong_type (env
, Qvectorp
, lvec
);
658 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
659 doc
: /* Load module FILE. */)
662 dynlib_handle_ptr handle
;
663 emacs_init_function module_init
;
667 handle
= dynlib_open (SSDATA (file
));
669 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
671 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
673 error ("Module %s is not GPL compatible", SDATA (file
));
675 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
677 error ("Module %s does not have an init function.", SDATA (file
));
679 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
680 struct emacs_env_private priv
;
681 initialize_environment (&rt
.pub
, &priv
);
682 struct emacs_runtime pub
=
685 .private_members
= &rt
,
686 .get_environment
= module_get_environment
688 int r
= module_init (&pub
);
689 finalize_environment (&priv
);
693 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
694 xsignal0 (Qoverflow_error
);
695 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
701 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 1, MANY
, 0,
702 doc
: /* Internal function to call a module function.
703 ENVOBJ is a save pointer to a module_fun_env structure.
704 ARGLIST is a list of arguments passed to SUBRPTR.
705 usage: (module-call ENVOBJ &rest ARGLIST) */)
706 (ptrdiff_t nargs
, Lisp_Object
*arglist
)
708 Lisp_Object envobj
= arglist
[0];
709 /* FIXME: Rather than use a save_value, we should create a new object type.
710 Making save_value visible to Lisp is wrong. */
711 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
712 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
713 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
714 /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
715 is a module_fun_env pointer. If some other part of Emacs also
716 exports save_value objects to Elisp, than we may be getting here this
717 other kind of save_value which will likely hold something completely
718 different in this field. */
719 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
720 EMACS_INT len
= nargs
- 1;
721 eassume (0 <= envptr
->min_arity
);
722 if (! (envptr
->min_arity
<= len
723 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
724 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
728 struct emacs_env_private priv
;
729 initialize_environment (&pub
, &priv
);
732 #ifdef WIDE_EMACS_INT
733 emacs_value
*args
= SAFE_ALLOCA (len
* sizeof *args
);
735 for (ptrdiff_t i
= 0; i
< len
; i
++)
736 args
[i
] = lisp_to_value (arglist
[i
+ 1]);
738 /* BEWARE! Here, we assume that Lisp_Object and
739 * emacs_value have the exact same representation. */
740 emacs_value
*args
= (emacs_value
*) arglist
+ 1;
743 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
746 eassert (&priv
== pub
.private_members
);
748 switch (priv
.pending_non_local_exit
)
750 case emacs_funcall_exit_return
:
751 finalize_environment (&priv
);
752 return value_to_lisp (ret
);
753 case emacs_funcall_exit_signal
:
755 Lisp_Object symbol
= priv
.non_local_exit_symbol
;
756 Lisp_Object data
= priv
.non_local_exit_data
;
757 finalize_environment (&priv
);
758 xsignal (symbol
, data
);
760 case emacs_funcall_exit_throw
:
762 Lisp_Object tag
= priv
.non_local_exit_symbol
;
763 Lisp_Object value
= priv
.non_local_exit_data
;
764 finalize_environment (&priv
);
773 /* Helper functions. */
776 check_main_thread (void)
778 #ifdef HAVE_THREADS_H
779 eassert (thrd_equal (thdr_current (), main_thread
));
780 #elif defined HAVE_PTHREAD
781 eassert (pthread_equal (pthread_self (), main_thread
));
782 #elif defined WINDOWSNT
783 eassert (GetCurrentThreadId () == main_thread
);
788 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
791 struct emacs_env_private
*p
= env
->private_members
;
792 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
794 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
795 p
->non_local_exit_symbol
= sym
;
796 p
->non_local_exit_data
= data
;
801 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
804 struct emacs_env_private
*p
= env
->private_members
;
805 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
807 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
808 p
->non_local_exit_symbol
= tag
;
809 p
->non_local_exit_data
= value
;
813 /* Module version of `wrong_type_argument'. */
815 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
817 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
818 list2 (predicate
, value
));
821 /* Signal an out-of-memory condition to the caller. */
823 module_out_of_memory (emacs_env
*env
)
825 /* TODO: Reimplement this so it works even if memory-signal-data has
827 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
828 XCDR (Vmemory_signal_data
));
831 /* Signal arguments are out of range. */
833 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
835 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
839 /* Value conversion. */
841 #ifdef WIDE_EMACS_INT
842 /* Unique Lisp_Object used to mark those emacs_values which are really
843 just containers holding a Lisp_Object that's too large for emacs_value. */
844 static Lisp_Object ltv_mark
;
847 /* Convert an `emacs_value' to the corresponding internal object.
850 value_to_lisp (emacs_value v
)
852 #ifdef WIDE_EMACS_INT
853 EMACS_INT tmp
= (EMACS_INT
)v
;
854 int tag
= tmp
& ((1 << GCTYPEBITS
) - 1);
859 o
= make_lisp_ptr ((tmp
- tag
) >> GCTYPEBITS
, tag
); break;
861 o
= make_lisp_ptr ((void*)(tmp
- tag
), tag
);
863 /* eassert (lisp_to_value (o) == v); */
864 if (CONSP (o
) && EQ (XCDR (o
), ltv_mark
))
869 Lisp_Object o
= XIL ((EMACS_INT
) v
);
870 /* Check the assumption made elsewhere that Lisp_Object and emacs_value
871 share the same underlying bit representation. */
872 eassert (EQ (o
, *(Lisp_Object
*)&v
));
873 /* eassert (lisp_to_value (o) == v); */
878 /* Convert an internal object to an `emacs_value'. Allocate storage
879 from the environment; return NULL if allocation fails. */
881 lisp_to_value (Lisp_Object o
)
883 EMACS_INT i
= XLI (o
);
884 #ifdef WIDE_EMACS_INT
885 /* We need to compress the EMACS_INT into the space of a pointer.
886 For most objects, this is just a question of shuffling the tags around.
887 But in some cases (e.g. large integers) this can't be done, so we
888 should allocate a special object to hold the extra data. */
894 EMACS_UINT val
= i
& VALMASK
;
895 if (val
== (EMACS_UINT
)(emacs_value
)val
)
897 emacs_value v
= (emacs_value
) ((val
<< GCTYPEBITS
) | tag
);
898 eassert (EQ (value_to_lisp (v
), o
));
902 o
= Fcons (o
, ltv_mark
);
906 void *ptr
= XUNTAG (o
, tag
);
907 if (((EMACS_UINT
)ptr
) & ((1 << GCTYPEBITS
) - 1))
908 { /* Pointer is not properly aligned! */
909 eassert (!CONSP (o
)); /* Cons cells have to always be aligned! */
910 o
= Fcons (o
, ltv_mark
);
911 ptr
= XUNTAG (o
, tag
);
913 emacs_value v
= (emacs_value
)(((EMACS_UINT
) ptr
) | tag
);
914 eassert (EQ (value_to_lisp (v
), o
));
919 emacs_value v
= (emacs_value
)i
;
920 /* Check the assumption made elsewhere that Lisp_Object and emacs_value
921 share the same underlying bit representation. */
922 eassert (v
== *(emacs_value
*)&o
);
923 eassert (EQ (value_to_lisp (v
), o
));
929 /* Memory management. */
931 /* Mark all objects allocated from local environments so that they
932 don't get garbage-collected. */
939 /* Environment lifetime management. */
941 /* Must be called before the environment can be used. */
943 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
945 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
946 env
->size
= sizeof *env
;
947 env
->private_members
= priv
;
948 env
->make_global_ref
= module_make_global_ref
;
949 env
->free_global_ref
= module_free_global_ref
;
950 env
->non_local_exit_check
= module_non_local_exit_check
;
951 env
->non_local_exit_clear
= module_non_local_exit_clear
;
952 env
->non_local_exit_get
= module_non_local_exit_get
;
953 env
->non_local_exit_signal
= module_non_local_exit_signal
;
954 env
->non_local_exit_throw
= module_non_local_exit_throw
;
955 env
->make_function
= module_make_function
;
956 env
->funcall
= module_funcall
;
957 env
->intern
= module_intern
;
958 env
->type_of
= module_type_of
;
959 env
->is_not_nil
= module_is_not_nil
;
961 env
->extract_integer
= module_extract_integer
;
962 env
->make_integer
= module_make_integer
;
963 env
->extract_float
= module_extract_float
;
964 env
->make_float
= module_make_float
;
965 env
->copy_string_contents
= module_copy_string_contents
;
966 env
->make_string
= module_make_string
;
967 env
->make_user_ptr
= module_make_user_ptr
;
968 env
->get_user_ptr
= module_get_user_ptr
;
969 env
->set_user_ptr
= module_set_user_ptr
;
970 env
->get_user_finalizer
= module_get_user_finalizer
;
971 env
->set_user_finalizer
= module_set_user_finalizer
;
972 env
->vec_set
= module_vec_set
;
973 env
->vec_get
= module_vec_get
;
974 env
->vec_size
= module_vec_size
;
975 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
978 /* Must be called before the lifetime of the environment object
981 finalize_environment (struct emacs_env_private
*env
)
983 Vmodule_environments
= XCDR (Vmodule_environments
);
987 /* Non-local exit handling. */
989 /* Must be called after setting up a handler immediately before
990 returning from the function. See the comments in lisp.h and the
991 code in eval.c for details. The macros below arrange for this
992 function to be called automatically. DUMMY is ignored. */
994 module_reset_handlerlist (const int *dummy
)
996 handlerlist
= handlerlist
->next
;
999 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1000 stored in the environment. Set the pending non-local exit flag. */
1002 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1004 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1007 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1008 stored in the environment. Set the pending non-local exit flag. */
1010 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1012 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1016 /* Function environments. */
1018 /* Return a string object that contains a user-friendly
1019 representation of the function environment. */
1021 module_format_fun_env (const struct module_fun_env
*env
)
1023 /* Try to print a function name if possible. */
1024 const char *path
, *sym
;
1025 static char const noaddr_format
[] = "#<module function at %p>";
1026 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
1028 ptrdiff_t bufsize
= sizeof buffer
;
1030 = (dynlib_addr (env
->subr
, &path
, &sym
)
1031 ? exprintf (&buf
, &bufsize
, buffer
, -1,
1032 "#<module function %s from %s>", sym
, path
)
1033 : sprintf (buffer
, noaddr_format
, env
->subr
));
1034 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
1037 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
1041 /* Segment initializer. */
1044 syms_of_module (void)
1046 module_nil
= lisp_to_value (Qnil
);
1047 #ifdef WIDE_EMACS_INT
1048 ltv_mark
= Fcons (Qnil
, Qnil
);
1051 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1052 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1053 doc
: /* Module global reference table. */);
1056 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1057 make_float (DEFAULT_REHASH_SIZE
),
1058 make_float (DEFAULT_REHASH_THRESHOLD
),
1060 Funintern (Qmodule_refs_hash
, Qnil
);
1062 DEFSYM (Qmodule_environments
, "module-environments");
1063 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1064 doc
: /* List of active module environments. */);
1065 Vmodule_environments
= Qnil
;
1066 /* Unintern `module-environments' because it is only used
1068 Funintern (Qmodule_environments
, Qnil
);
1070 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1071 Fput (Qmodule_load_failed
, Qerror_conditions
,
1072 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1073 Fput (Qmodule_load_failed
, Qerror_message
,
1074 build_pure_c_string ("Module load failed"));
1076 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1077 Fput (Qinvalid_module_call
, Qerror_conditions
,
1078 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1079 Fput (Qinvalid_module_call
, Qerror_message
,
1080 build_pure_c_string ("Invalid module call"));
1082 DEFSYM (Qinvalid_arity
, "invalid-arity");
1083 Fput (Qinvalid_arity
, Qerror_conditions
,
1084 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1085 Fput (Qinvalid_arity
, Qerror_message
,
1086 build_pure_c_string ("Invalid function arity"));
1088 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1089 code or modules should not access it. */
1090 Funintern (Qmodule_refs_hash
, Qnil
);
1092 DEFSYM (Qsave_value_p
, "save-value-p");
1093 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1095 defsubr (&Smodule_load
);
1097 DEFSYM (Qinternal_module_call
, "internal--module-call");
1098 defsubr (&Sinternal_module_call
);
1101 /* Unlike syms_of_module, this initializer is called even from an
1102 initialized (dumped) Emacs. */
1107 /* It is not guaranteed that dynamic initializers run in the main thread,
1108 therefore detect the main thread here. */
1109 #ifdef HAVE_THREADS_H
1110 main_thread
= thrd_current ();
1111 #elif defined HAVE_PTHREAD
1112 main_thread
= pthread_self ();
1113 #elif defined WINDOWSNT
1114 /* The 'main' function already recorded the main thread's thread ID,
1115 so we need just to use it . */
1116 main_thread
= dwMainThreadId
;