this merges frmo trunk and fixes various build issues.
this needed a few ugly tweaks.
this hangs in "make check" now
dnl checks for header files
AC_CHECK_HEADERS_ONCE(
- linux/version.h sys/systeminfo.h
+ sys/systeminfo.h
coff.h pty.h
sys/resource.h
- sys/utsname.h pwd.h utmp.h util.h)
+ sys/utsname.h pwd.h utmp.h util.h sys/prctl.h)
AC_MSG_CHECKING(if personality LINUX32 can be set)
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])],
difftime posix_memalign \
getpwent endpwent getgrent endgrent \
touchlock \
- cfmakeraw cfsetspeed copysign __executable_start prctl)
-cfmakeraw cfsetspeed copysign __executable_start log2)
++cfmakeraw cfsetspeed copysign __executable_start log2 prctl)
## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines
## has a broken `rint' in some library versions including math library
if (!BUFFER_LIVE_P (b))
return Qnil;
- /* Query if the buffer is still modified. */
- if (INTERACTIVE && !NILP (BVAR (b, filename))
- && BUF_MODIFF (b) > BUF_SAVE_MODIFF (b))
- {
- GCPRO1 (buffer);
- tem = do_yes_or_no_p (format2 ("Buffer %s modified; kill anyway? ",
- BVAR (b, name), make_number (0)));
- UNGCPRO;
- if (NILP (tem))
- return Qnil;
- }
-
+ if (thread_check_current_buffer (b))
+ return Qnil;
+
/* Run hooks with the buffer to be killed the current buffer. */
{
ptrdiff_t count = SPECPDL_INDEX ();
static Lisp_Object Qcompiled_function, Qframe;
Lisp_Object Qbuffer;
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
- static Lisp_Object Qsubrp, Qmany, Qunevalled;
+ static Lisp_Object Qsubrp;
+ static Lisp_Object Qmany, Qunevalled;
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
static Lisp_Object Qdefun;
+Lisp_Object Qthread, Qmutex, Qcondition_variable;
Lisp_Object Qinteractive_form;
static Lisp_Object Qdefalias_fset_function;
Lisp_Object Vautoload_queue;
- /* Current number of specbindings allocated in specpdl. */
+ /* Current number of specbindings allocated in specpdl, not counting
+ the dummy entry specpdl[-1]. */
-ptrdiff_t specpdl_size;
+/* ptrdiff_t specpdl_size; */
- /* Pointer to beginning of specpdl. */
+ /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
+ only so that its address can be taken. */
- /* struct specbinding *specpdl; */
-union specbinding *specpdl;
++/* union specbinding *specpdl; */
/* Pointer to first unused element in specpdl. */
- /* struct specbinding *specpdl_ptr; */
-union specbinding *specpdl_ptr;
++/* union specbinding *specpdl_ptr; */
/* Depth in Lisp evaluations and function calls. */
static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
+ static Lisp_Object
+ specpdl_symbol (union specbinding *pdl)
+ {
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.symbol;
+ }
+
+ static Lisp_Object
+ specpdl_old_value (union specbinding *pdl)
+ {
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.old_value;
+ }
+
+ static Lisp_Object
+ specpdl_where (union specbinding *pdl)
+ {
+ eassert (pdl->kind > SPECPDL_LET);
+ return pdl->let.where;
+ }
+
++static Lisp_Object
++specpdl_saved_value (union specbinding *pdl)
++{
++ eassert (pdl->kind >= SPECPDL_LET);
++ return pdl->let.saved_value;
++}
++
+ static Lisp_Object
+ specpdl_arg (union specbinding *pdl)
+ {
+ eassert (pdl->kind == SPECPDL_UNWIND);
+ return pdl->unwind.arg;
+ }
+
+ static specbinding_func
+ specpdl_func (union specbinding *pdl)
+ {
+ eassert (pdl->kind == SPECPDL_UNWIND);
+ return pdl->unwind.func;
+ }
+
+ static Lisp_Object
+ backtrace_function (union specbinding *pdl)
+ {
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.function;
+ }
+
+ static ptrdiff_t
+ backtrace_nargs (union specbinding *pdl)
+ {
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.nargs;
+ }
+
+ static Lisp_Object *
+ backtrace_args (union specbinding *pdl)
+ {
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.args;
+ }
+
+ static bool
+ backtrace_debug_on_exit (union specbinding *pdl)
+ {
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.debug_on_exit;
+ }
+
/* Functions to modify slots of backtrace records. */
static void
return 0;
}
- binding_symbol (struct specbinding *bind)
+static Lisp_Object
- do_specbind (struct Lisp_Symbol *sym, struct specbinding *bind,
++binding_symbol (union specbinding *bind)
+{
+ if (!CONSP (specpdl_symbol (bind)))
+ return specpdl_symbol (bind);
+ return XCAR (specpdl_symbol (bind));
+}
+
+void
++do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
+ Lisp_Object value)
+{
+ switch (sym->redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ if (!sym->constant)
+ SET_SYMBOL_VAL (sym, value);
+ else
+ set_internal (specpdl_symbol (bind), value, Qnil, 1);
+ break;
+
+ case SYMBOL_LOCALIZED:
+ case SYMBOL_FORWARDED:
+ if ((sym->redirect == SYMBOL_LOCALIZED
+ || BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
+ && CONSP (specpdl_symbol (bind)))
+ {
+ Lisp_Object where;
+
+ where = XCAR (XCDR (specpdl_symbol (bind)));
+ if (NILP (where)
+ && sym->redirect == SYMBOL_FORWARDED)
+ {
+ Fset_default (XCAR (specpdl_symbol (bind)), value);
+ return;
+ }
+ }
+
+ set_internal (binding_symbol (bind), value, Qnil, 1);
+ break;
+
+ default:
+ abort ();
+ }
+}
+
/* `specpdl_ptr->symbol' is a field which describes which variable is
let-bound, so it can be properly undone when we unbind_to.
It can have the following two shapes:
case SYMBOL_PLAINVAL:
/* The most common case is that of a non-constant symbol with a
trivial value. Make that as fast as we can. */
- specpdl_ptr->kind = SPECPDL_LET;
- specpdl_ptr->v.let.symbol = symbol;
- specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym);
- specpdl_ptr->v.let.saved_value = Qnil;
+ specpdl_ptr->let.kind = SPECPDL_LET;
+ specpdl_ptr->let.symbol = symbol;
+ specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
++ specpdl_ptr->let.saved_value = Qnil;
++specpdl_ptr;
- if (!sym->constant)
- SET_SYMBOL_VAL (sym, value);
- else
- set_internal (symbol, value, Qnil, 1);
+ do_specbind (sym, specpdl_ptr - 1, value);
break;
case SYMBOL_LOCALIZED:
if (SYMBOL_BLV (sym)->frame_local)
case SYMBOL_FORWARDED:
{
Lisp_Object ovalue = find_symbol_value (symbol);
- specpdl_ptr->kind = SPECPDL_LET_LOCAL;
- specpdl_ptr->v.let.symbol = symbol;
- specpdl_ptr->v.let.old_value = ovalue;
- specpdl_ptr->v.let.where = Fcurrent_buffer ();
- specpdl_ptr->v.let.saved_value = Qnil;
+ specpdl_ptr->let.kind = SPECPDL_LET_LOCAL;
+ specpdl_ptr->let.symbol = symbol;
+ specpdl_ptr->let.old_value = ovalue;
+ specpdl_ptr->let.where = Fcurrent_buffer ();
++ specpdl_ptr->let.saved_value = Qnil;
eassert (sym->redirect != SYMBOL_LOCALIZED
|| (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
happens with other buffer-local variables. */
if (NILP (Flocal_variable_p (symbol, Qnil)))
{
- specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
+ specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
++specpdl_ptr;
- Fset_default (symbol, value);
+ do_specbind (sym, specpdl_ptr - 1, value);
return;
}
}
else
- specpdl_ptr->kind = SPECPDL_LET;
+ specpdl_ptr->let.kind = SPECPDL_LET;
specpdl_ptr++;
- set_internal (symbol, value, Qnil, 1);
+ do_specbind (sym, specpdl_ptr - 1, value);
break;
}
default: emacs_abort ();
specpdl_ptr++;
}
- struct specbinding *bind;
+void
+rebind_for_thread_switch (void)
+{
- bind->v.let.saved_value = Qnil;
++ union specbinding *bind;
+
+ for (bind = specpdl; bind != specpdl_ptr; ++bind)
+ {
+ if (bind->kind >= SPECPDL_LET)
+ {
+ Lisp_Object value = specpdl_saved_value (bind);
+
- do_one_unbind (struct specbinding *this_binding, int unwinding)
++ bind->let.saved_value = Qnil;
+ do_specbind (XSYMBOL (binding_symbol (bind)), bind, value);
+ }
+ }
+}
+
+static void
- (*specpdl_func (this_binding)) (specpdl_arg (this_binding));
++do_one_unbind (union specbinding *this_binding, int unwinding)
+{
+ eassert (unwinding || this_binding->kind >= SPECPDL_LET);
+ switch (this_binding->kind)
+ {
+ case SPECPDL_UNWIND:
++ specpdl_func (this_binding) (specpdl_arg (this_binding));
+ break;
+ case SPECPDL_LET:
+ /* If variable has a trivial value (no forwarding), we can
+ just set it. No need to check for constant symbols here,
+ since that was already done by specbind. */
+ if (XSYMBOL (specpdl_symbol (this_binding))->redirect
+ == SYMBOL_PLAINVAL)
+ SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (this_binding)),
+ specpdl_old_value (this_binding));
+ else
+ /* NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ Fset_default (specpdl_symbol (this_binding),
+ specpdl_old_value (this_binding));
+ break;
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET_LOCAL:
+ case SPECPDL_LET_DEFAULT:
+ { /* If the symbol is a list, it is really (SYMBOL WHERE
+ . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
+ frame. If WHERE is a buffer or frame, this indicates we
+ bound a variable that had a buffer-local or frame-local
+ binding. WHERE nil means that the variable had the default
+ value when it was bound. CURRENT-BUFFER is the buffer that
+ was current when the variable was bound. */
+ Lisp_Object symbol = specpdl_symbol (this_binding);
+ Lisp_Object where = specpdl_where (this_binding);
+ eassert (BUFFERP (where));
+
+ if (this_binding->kind == SPECPDL_LET_DEFAULT)
+ Fset_default (symbol, specpdl_old_value (this_binding));
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ else if (!NILP (Flocal_variable_p (symbol, where)))
+ set_internal (symbol, specpdl_old_value (this_binding),
+ where, 1);
+ }
+ break;
+ }
+}
+
Lisp_Object
unbind_to (ptrdiff_t count, Lisp_Object value)
{
while (specpdl_ptr != specpdl + count)
{
- /* Decrement specpdl_ptr before we do the work to unbind it, so
- that an error in unbinding won't try to unbind the same entry
- again. Take care to copy any parts of the binding needed
- before invoking any code that can make more bindings. */
+ /* Copy the binding, and decrement specpdl_ptr, before we do
+ the work to unbind it. We decrement first
+ so that an error in unbinding won't try to unbind
+ the same entry again, and we copy the binding first
+ in case more bindings are made during some of the code we run. */
- struct specbinding this_binding;
- specpdl_ptr--;
++ union specbinding this_binding;
+ this_binding = *--specpdl_ptr;
- switch (specpdl_ptr->kind)
- {
- case SPECPDL_UNWIND:
- specpdl_func (specpdl_ptr) (specpdl_arg (specpdl_ptr));
- break;
- case SPECPDL_LET:
- /* If variable has a trivial value (no forwarding), we can
- just set it. No need to check for constant symbols here,
- since that was already done by specbind. */
- if (XSYMBOL (specpdl_symbol (specpdl_ptr))->redirect
- == SYMBOL_PLAINVAL)
- SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr)),
- specpdl_old_value (specpdl_ptr));
- else
- /* NOTE: we only ever come here if make_local_foo was used for
- the first time on this var within this let. */
- Fset_default (specpdl_symbol (specpdl_ptr),
- specpdl_old_value (specpdl_ptr));
- break;
- case SPECPDL_BACKTRACE:
- break;
- case SPECPDL_LET_LOCAL:
- case SPECPDL_LET_DEFAULT:
- { /* If the symbol is a list, it is really (SYMBOL WHERE
- . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
- frame. If WHERE is a buffer or frame, this indicates we
- bound a variable that had a buffer-local or frame-local
- binding. WHERE nil means that the variable had the default
- value when it was bound. CURRENT-BUFFER is the buffer that
- was current when the variable was bound. */
- Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
- Lisp_Object where = specpdl_where (specpdl_ptr);
- Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
- eassert (BUFFERP (where));
-
- if (specpdl_ptr->kind == SPECPDL_LET_DEFAULT)
- Fset_default (symbol, old_value);
- /* If this was a local binding, reset the value in the appropriate
- buffer, but only if that buffer's binding still exists. */
- else if (!NILP (Flocal_variable_p (symbol, where)))
- set_internal (symbol, old_value, where, 1);
- }
- break;
- }
+ do_one_unbind (&this_binding, 1);
}
if (NILP (Vquit_flag) && !NILP (quitf))
return value;
}
- struct specbinding *bind;
+void
+unbind_for_thread_switch (void)
+{
- bind->v.let.saved_value = find_symbol_value (binding_symbol (bind));
++ union specbinding *bind;
+
+ for (bind = specpdl_ptr; bind != specpdl; --bind)
+ {
+ if (bind->kind >= SPECPDL_LET)
+ {
++ bind->let.saved_value = find_symbol_value (binding_symbol (bind));
+ do_one_unbind (bind, 0);
+ }
+ }
+}
+
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
doc: /* Return non-nil if SYMBOL's global binding has been declared special.
A special variable is one that will be bound dynamically, even in a
\f
void
- mark_specpdl (struct specbinding *first, struct specbinding *ptr)
-mark_specpdl (void)
++mark_specpdl (union specbinding *first, union specbinding *ptr)
{
- struct specbinding *pdl;
+ union specbinding *pdl;
- for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
+ for (pdl = first; pdl != ptr; pdl++)
{
switch (pdl->kind)
{
case SPECPDL_LET:
mark_object (specpdl_symbol (pdl));
mark_object (specpdl_old_value (pdl));
+ mark_object (specpdl_saved_value (pdl));
+ break;
}
}
}
enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = 0 };
#endif /* CHECK_LISP_OBJECT_TYPE */
++/* Header of vector-like objects. This documents the layout constraints on
++ vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
++ compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
++ and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
++ because when two such pointers potentially alias, a compiler won't
++ incorrectly reorder loads and stores to their size fields. See
++ <http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8546>. */
++struct vectorlike_header
++ {
++ /* The only field contains various pieces of information:
++ - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
++ - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
++ vector (0) or a pseudovector (1).
++ - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
++ of slots) of the vector.
++ - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
++ - a) pseudovector subtype held in PVEC_TYPE_MASK field;
++ - b) number of Lisp_Objects slots at the beginning of the object
++ held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
++ traced by the GC;
++ - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
++ measured in word_size units. Rest fields may also include
++ Lisp_Objects, but these objects usually needs some special treatment
++ during GC.
++ There are some exceptions. For PVEC_FREE, b) is always zero. For
++ PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
++ Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
++ 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
++ ptrdiff_t size;
++ };
++
++#include "thread.h"
++
+ /* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
+ At the machine level, these operations are no-ops. */
+ LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o))
+ LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i))
+
/* In the size word of a vector, this bit means the vector has been marked. */
static ptrdiff_t const ARRAY_MARK_FLAG
{
return num < lower ? lower : num <= upper ? num : upper;
}
+ \f
+ /* Forward declarations. */
+
+ /* Defined in this file. */
+ union Lisp_Fwd;
+ LISP_INLINE bool BOOL_VECTOR_P (Lisp_Object);
+ LISP_INLINE bool BUFFER_OBJFWDP (union Lisp_Fwd *);
+ LISP_INLINE bool BUFFERP (Lisp_Object);
+ LISP_INLINE bool CHAR_TABLE_P (Lisp_Object);
+ LISP_INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object, ptrdiff_t);
+ LISP_INLINE bool (CONSP) (Lisp_Object);
+ LISP_INLINE bool (FLOATP) (Lisp_Object);
+ LISP_INLINE bool functionp (Lisp_Object);
+ LISP_INLINE bool (INTEGERP) (Lisp_Object);
+ LISP_INLINE bool (MARKERP) (Lisp_Object);
+ LISP_INLINE bool (MISCP) (Lisp_Object);
+ LISP_INLINE bool (NILP) (Lisp_Object);
+ LISP_INLINE bool OVERLAYP (Lisp_Object);
+ LISP_INLINE bool PROCESSP (Lisp_Object);
+ LISP_INLINE bool PSEUDOVECTORP (Lisp_Object, int);
+ LISP_INLINE bool SAVE_VALUEP (Lisp_Object);
+ LISP_INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
+ Lisp_Object);
+ LISP_INLINE bool STRINGP (Lisp_Object);
+ LISP_INLINE bool SUB_CHAR_TABLE_P (Lisp_Object);
+ LISP_INLINE bool SUBRP (Lisp_Object);
+ LISP_INLINE bool (SYMBOLP) (Lisp_Object);
+ LISP_INLINE bool (VECTORLIKEP) (Lisp_Object);
+ LISP_INLINE bool WINDOWP (Lisp_Object);
++LISP_INLINE bool THREADP (Lisp_Object);
++LISP_INLINE bool MUTEXP (Lisp_Object);
++LISP_INLINE bool CONDVARP (Lisp_Object);
+ LISP_INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
+
+ /* Defined in chartab.c. */
+ extern Lisp_Object char_table_ref (Lisp_Object, int);
+ extern void char_table_set (Lisp_Object, int, Lisp_Object);
+ extern int char_table_translate (Lisp_Object, int);
+
+ /* Defined in data.c. */
+ extern Lisp_Object Qarrayp, Qbufferp, Qbuffer_or_string_p, Qchar_table_p;
+ extern Lisp_Object Qconsp, Qfloatp, Qintegerp, Qlambda, Qlistp, Qmarkerp, Qnil;
+ extern Lisp_Object Qnumberp, Qstringp, Qsymbolp, Qvectorp;
+ extern Lisp_Object Qvector_or_char_table_p, Qwholenump;
+ extern Lisp_Object Ffboundp (Lisp_Object);
+ extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object);
+
+ /* Defined in emacs.c. */
+ extern bool initialized;
+
+ /* Defined in eval.c. */
+ extern Lisp_Object Qautoload;
+
+ /* Defined in floatfns.c. */
+ extern double extract_float (Lisp_Object);
+
+ /* Defined in process.c. */
+ extern Lisp_Object Qprocessp;
+
++/* Defined in thread.c. */
++extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep;
++
+ /* Defined in window.c. */
+ extern Lisp_Object Qwindowp;
+ /* Defined in xdisp.c. */
+ extern Lisp_Object Qimage;
\f
+
/* Extract a value or address from a Lisp_Object. */
- #define XCONS(a) (eassert (CONSP (a)), \
- (struct Lisp_Cons *) XUNTAG (a, Lisp_Cons))
- #define XVECTOR(a) (eassert (VECTORLIKEP (a)), \
- (struct Lisp_Vector *) XUNTAG (a, Lisp_Vectorlike))
- #define XSTRING(a) (eassert (STRINGP (a)), \
- (struct Lisp_String *) XUNTAG (a, Lisp_String))
- #define XSYMBOL(a) (eassert (SYMBOLP (a)), \
- (struct Lisp_Symbol *) XUNTAG (a, Lisp_Symbol))
- #define XFLOAT(a) (eassert (FLOATP (a)), \
- (struct Lisp_Float *) XUNTAG (a, Lisp_Float))
+ LISP_MACRO_DEFUN (XCONS, struct Lisp_Cons *, (Lisp_Object a), (a))
- /* Misc types. */
+ LISP_INLINE struct Lisp_Vector *
+ XVECTOR (Lisp_Object a)
+ {
+ eassert (VECTORLIKEP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
- #define XMISC(a) ((union Lisp_Misc *) XUNTAG (a, Lisp_Misc))
- #define XMISCANY(a) (eassert (MISCP (a)), &(XMISC (a)->u_any))
- #define XMISCTYPE(a) (XMISCANY (a)->type)
- #define XMARKER(a) (eassert (MARKERP (a)), &(XMISC (a)->u_marker))
- #define XOVERLAY(a) (eassert (OVERLAYP (a)), &(XMISC (a)->u_overlay))
+ LISP_INLINE struct Lisp_String *
+ XSTRING (Lisp_Object a)
+ {
+ eassert (STRINGP (a));
+ return XUNTAG (a, Lisp_String);
+ }
- /* Forwarding object types. */
+ LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a))
- #define XFWDTYPE(a) (a->u_intfwd.type)
- #define XINTFWD(a) (eassert (INTFWDP (a)), &((a)->u_intfwd))
- #define XBOOLFWD(a) (eassert (BOOLFWDP (a)), &((a)->u_boolfwd))
- #define XOBJFWD(a) (eassert (OBJFWDP (a)), &((a)->u_objfwd))
- #define XBUFFER_OBJFWD(a) \
- (eassert (BUFFER_OBJFWDP (a)), &((a)->u_buffer_objfwd))
- #define XKBOARD_OBJFWD(a) \
- (eassert (KBOARD_OBJFWDP (a)), &((a)->u_kboard_objfwd))
+ LISP_INLINE struct Lisp_Float *
+ XFLOAT (Lisp_Object a)
+ {
+ eassert (FLOATP (a));
+ return XUNTAG (a, Lisp_Float);
+ }
/* Pseudovector types. */
- struct Lisp_Process;
- LISP_INLINE Lisp_Object make_lisp_proc (struct Lisp_Process *p)
- { return make_lisp_ptr (p, Lisp_Vectorlike); }
- #define XPROCESS(a) (eassert (PROCESSP (a)), \
- (struct Lisp_Process *) XUNTAG (a, Lisp_Vectorlike))
- #define XWINDOW(a) (eassert (WINDOWP (a)), \
- (struct window *) XUNTAG (a, Lisp_Vectorlike))
- #define XTERMINAL(a) (eassert (TERMINALP (a)), \
- (struct terminal *) XUNTAG (a, Lisp_Vectorlike))
- #define XSUBR(a) (eassert (SUBRP (a)), \
- (struct Lisp_Subr *) XUNTAG (a, Lisp_Vectorlike))
- #define XBUFFER(a) (eassert (BUFFERP (a)), \
- (struct buffer *) XUNTAG (a, Lisp_Vectorlike))
- #define XCHAR_TABLE(a) (eassert (CHAR_TABLE_P (a)), \
- (struct Lisp_Char_Table *) XUNTAG (a, Lisp_Vectorlike))
- #define XSUB_CHAR_TABLE(a) (eassert (SUB_CHAR_TABLE_P (a)), \
- ((struct Lisp_Sub_Char_Table *) \
- XUNTAG (a, Lisp_Vectorlike)))
- #define XBOOL_VECTOR(a) (eassert (BOOL_VECTOR_P (a)), \
- ((struct Lisp_Bool_Vector *) \
- XUNTAG (a, Lisp_Vectorlike)))
- #define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a))
- #define XMUTEX(a) (eassert (MUTEXP (a)), (struct Lisp_Mutex *) XPNTR(a))
- #define XCONDVAR(a) (eassert (CONDVARP (a)), (struct Lisp_CondVar *) XPNTR(a))
+
+ LISP_INLINE struct Lisp_Process *
+ XPROCESS (Lisp_Object a)
+ {
+ eassert (PROCESSP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct window *
+ XWINDOW (Lisp_Object a)
+ {
+ eassert (WINDOWP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct terminal *
+ XTERMINAL (Lisp_Object a)
+ {
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct Lisp_Subr *
+ XSUBR (Lisp_Object a)
+ {
+ eassert (SUBRP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct buffer *
+ XBUFFER (Lisp_Object a)
+ {
+ eassert (BUFFERP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct Lisp_Char_Table *
+ XCHAR_TABLE (Lisp_Object a)
+ {
+ eassert (CHAR_TABLE_P (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct Lisp_Sub_Char_Table *
+ XSUB_CHAR_TABLE (Lisp_Object a)
+ {
+ eassert (SUB_CHAR_TABLE_P (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
+ LISP_INLINE struct Lisp_Bool_Vector *
+ XBOOL_VECTOR (Lisp_Object a)
+ {
+ eassert (BOOL_VECTOR_P (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+ }
+
++LISP_INLINE struct thread_state *
++XTHREAD (Lisp_Object a)
++{
++ eassert (THREADP (a));
++ return XUNTAG (a, Lisp_Vectorlike);
++}
++
++LISP_INLINE struct Lisp_Mutex *
++XMUTEX (Lisp_Object a)
++{
++ eassert (MUTEXP (a));
++ return XUNTAG (a, Lisp_Vectorlike);
++}
++
++LISP_INLINE struct Lisp_CondVar *
++XCONDVAR (Lisp_Object a)
++{
++ eassert (CONDVARP (a));
++ return XUNTAG (a, Lisp_Vectorlike);
++}
+
/* Construct a Lisp_Object from a value or address. */
+ LISP_INLINE Lisp_Object
+ make_lisp_ptr (void *ptr, enum Lisp_Type type)
+ {
+ EMACS_UINT utype = type;
+ EMACS_UINT typebits = USE_LSB_TAG ? type : utype << VALBITS;
+ Lisp_Object a = XIL (typebits | (uintptr_t) ptr);
+ eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr);
+ return a;
+ }
+
+ LISP_INLINE Lisp_Object
+ make_lisp_proc (struct Lisp_Process *p)
+ {
+ return make_lisp_ptr (p, Lisp_Vectorlike);
+ }
+
#define XSETINT(a, b) ((a) = make_number (b))
+ #define XSETFASTINT(a, b) ((a) = make_natnum (b))
#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons))
#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike))
#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String))
#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
+#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
+#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
+#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
- /* Convenience macros for dealing with Lisp arrays. */
-
- #define AREF(ARRAY, IDX) XVECTOR ((ARRAY))->contents[IDX]
- #define ASIZE(ARRAY) XVECTOR ((ARRAY))->header.size
- #define ASET(ARRAY, IDX, VAL) \
- (eassert (0 <= (IDX) && (IDX) < ASIZE (ARRAY)), \
- XVECTOR (ARRAY)->contents[IDX] = (VAL))
-
- /* Convenience macros for dealing with Lisp strings. */
-
- #define SDATA(string) (XSTRING (string)->data + 0)
- #define SREF(string, index) (SDATA (string)[index] + 0)
- #define SSET(string, index, new) (SDATA (string)[index] = (new))
- #define SCHARS(string) (XSTRING (string)->size + 0)
- #define SBYTES(string) (STRING_BYTES (XSTRING (string)) + 0)
-
- /* Avoid "differ in sign" warnings. */
- #define SSDATA(x) ((char *) SDATA (x))
-
- #define STRING_SET_CHARS(string, newsize) \
- (XSTRING (string)->size = (newsize))
-
- #define STRING_COPYIN(string, index, new, count) \
- memcpy (SDATA (string) + index, new, count)
-
/* Type checking. */
- #define CHECK_TYPE(ok, Qxxxp, x) \
- do { if (!(ok)) wrong_type_argument (Qxxxp, (x)); } while (0)
+ LISP_MACRO_DEFUN_VOID (CHECK_TYPE, (int ok, Lisp_Object Qxxxp, Lisp_Object x),
+ (ok, Qxxxp, x))
/* Deprecated and will be removed soon. */
(STR) = empty_multibyte_string; \
else XSTRING (STR)->size_byte = XSTRING (STR)->size; } while (0)
- /* In a string or vector, the sign bit of the `size' is the gc mark bit. */
+ /* Convenience functions for dealing with Lisp strings. */
- struct Lisp_String
- {
- ptrdiff_t size;
- ptrdiff_t size_byte;
- INTERVAL intervals; /* Text properties in this string. */
- unsigned char *data;
- };
+ LISP_INLINE unsigned char *
+ SDATA (Lisp_Object string)
+ {
+ return XSTRING (string)->data;
+ }
+ LISP_INLINE char *
+ SSDATA (Lisp_Object string)
+ {
+ /* Avoid "differ in sign" warnings. */
+ return (char *) SDATA (string);
+ }
+ LISP_INLINE unsigned char
+ SREF (Lisp_Object string, ptrdiff_t index)
+ {
+ return SDATA (string)[index];
+ }
+ LISP_INLINE void
+ SSET (Lisp_Object string, ptrdiff_t index, unsigned char new)
+ {
+ SDATA (string)[index] = new;
+ }
+ LISP_INLINE ptrdiff_t
+ SCHARS (Lisp_Object string)
+ {
+ return XSTRING (string)->size;
+ }
- /* Header of vector-like objects. This documents the layout constraints on
- vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
- compilers from being fooled by Emacs's type punning: the XSETPSEUDOVECTOR
- and PSEUDOVECTORP macros cast their pointers to struct vectorlike_header *,
- because when two such pointers potentially alias, a compiler won't
- incorrectly reorder loads and stores to their size fields. See
- <http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8546>. */
- struct vectorlike_header
- {
- /* The only field contains various pieces of information:
- - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
- - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
- vector (0) or a pseudovector (1).
- - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
- of slots) of the vector.
- - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
- - a) pseudovector subtype held in PVEC_TYPE_MASK field;
- - b) number of Lisp_Objects slots at the beginning of the object
- held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
- traced by the GC;
- - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
- measured in word_size units. Rest fields may also include
- Lisp_Objects, but these objects usually needs some special treatment
- during GC.
- There are some exceptions. For PVEC_FREE, b) is always zero. For
- PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
- Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
- 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
- ptrdiff_t size;
- };
+ #ifdef GC_CHECK_STRING_BYTES
+ extern ptrdiff_t string_bytes (struct Lisp_String *);
+ #endif
+ LISP_INLINE ptrdiff_t
+ STRING_BYTES (struct Lisp_String *s)
+ {
+ #ifdef GC_CHECK_STRING_BYTES
+ return string_bytes (s);
+ #else
+ return s->size_byte < 0 ? s->size : s->size_byte;
+ #endif
+ }
+
+ LISP_INLINE ptrdiff_t
+ SBYTES (Lisp_Object string)
+ {
+ return STRING_BYTES (XSTRING (string));
+ }
+ LISP_INLINE void
+ STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize)
+ {
+ XSTRING (string)->size = newsize;
+ }
+ LISP_INLINE void
+ STRING_COPYIN (Lisp_Object string, ptrdiff_t index, char const *new,
+ ptrdiff_t count)
+ {
+ memcpy (SDATA (string) + index, new, count);
+ }
-/* Header of vector-like objects. This documents the layout constraints on
- vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
- compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
- and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
- because when two such pointers potentially alias, a compiler won't
- incorrectly reorder loads and stores to their size fields. See
- <http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8546>. */
-struct vectorlike_header
- {
- /* The only field contains various pieces of information:
- - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
- - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
- vector (0) or a pseudovector (1).
- - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
- of slots) of the vector.
- - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
- - a) pseudovector subtype held in PVEC_TYPE_MASK field;
- - b) number of Lisp_Objects slots at the beginning of the object
- held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
- traced by the GC;
- - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
- measured in word_size units. Rest fields may also include
- Lisp_Objects, but these objects usually needs some special treatment
- during GC.
- There are some exceptions. For PVEC_FREE, b) is always zero. For
- PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
- Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
- 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
- ptrdiff_t size;
- };
-
/* Regular vector is just a header plus array of Lisp_Objects. */
struct Lisp_Vector
\f
/* Data type checking. */
- #define NILP(x) EQ (x, Qnil)
+ LISP_MACRO_DEFUN (NILP, bool, (Lisp_Object x), (x))
- #define NUMBERP(x) (INTEGERP (x) || FLOATP (x))
- #define NATNUMP(x) (INTEGERP (x) && XINT (x) >= 0)
+ LISP_INLINE bool
+ NUMBERP (Lisp_Object x)
+ {
+ return INTEGERP (x) || FLOATP (x);
+ }
+ LISP_INLINE bool
+ NATNUMP (Lisp_Object x)
+ {
+ return INTEGERP (x) && 0 <= XINT (x);
+ }
+
+ LISP_INLINE bool
+ RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi)
+ {
+ return INTEGERP (x) && lo <= XINT (x) && XINT (x) <= hi;
+ }
- #define RANGED_INTEGERP(lo, x, hi) \
- (INTEGERP (x) && (lo) <= XINT (x) && XINT (x) <= (hi))
#define TYPE_RANGED_INTEGERP(type, x) \
- (TYPE_SIGNED (type) \
- ? RANGED_INTEGERP (TYPE_MINIMUM (type), x, TYPE_MAXIMUM (type)) \
- : RANGED_INTEGERP (0, x, TYPE_MAXIMUM (type)))
-
- #define INTEGERP(x) (LISP_INT_TAG_P (XTYPE ((x))))
- #define SYMBOLP(x) (XTYPE ((x)) == Lisp_Symbol)
- #define MISCP(x) (XTYPE ((x)) == Lisp_Misc)
- #define VECTORLIKEP(x) (XTYPE ((x)) == Lisp_Vectorlike)
- #define STRINGP(x) (XTYPE ((x)) == Lisp_String)
- #define CONSP(x) (XTYPE ((x)) == Lisp_Cons)
-
- #define FLOATP(x) (XTYPE ((x)) == Lisp_Float)
- #define VECTORP(x) (VECTORLIKEP (x) && !(ASIZE (x) & PSEUDOVECTOR_FLAG))
- #define OVERLAYP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay)
- #define MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker)
+ (INTEGERP (x) \
+ && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \
+ && XINT (x) <= TYPE_MAXIMUM (type))
+
+ LISP_MACRO_DEFUN (CONSP, bool, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN (FLOATP, bool, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN (MISCP, bool, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN (SYMBOLP, bool, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN (INTEGERP, bool, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN (VECTORLIKEP, bool, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN (MARKERP, bool, (Lisp_Object x), (x))
+
+ LISP_INLINE bool
+ STRINGP (Lisp_Object x)
+ {
+ return XTYPE (x) == Lisp_String;
+ }
+ LISP_INLINE bool
+ VECTORP (Lisp_Object x)
+ {
+ return VECTORLIKEP (x) && ! (ASIZE (x) & PSEUDOVECTOR_FLAG);
+ }
+ LISP_INLINE bool
+ OVERLAYP (Lisp_Object x)
+ {
+ return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay;
+ }
+ LISP_INLINE bool
+ SAVE_VALUEP (Lisp_Object x)
+ {
+ return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value;
+ }
+
+ LISP_INLINE bool
+ AUTOLOADP (Lisp_Object x)
+ {
+ return CONSP (x) && EQ (Qautoload, XCAR (x));
+ }
+
+ LISP_INLINE bool
+ BUFFER_OBJFWDP (union Lisp_Fwd *a)
+ {
+ return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj;
+ }
+
+ LISP_INLINE bool
+ PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code)
+ {
+ return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK))
+ == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)));
+ }
+
+ /* True if A is a pseudovector whose code is CODE. */
+ LISP_INLINE bool
+ PSEUDOVECTORP (Lisp_Object a, int code)
+ {
+ if (! VECTORLIKEP (a))
+ return 0;
+ else
+ {
+ /* Converting to struct vectorlike_header * avoids aliasing issues. */
+ struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike);
+ return PSEUDOVECTOR_TYPEP (h, code);
+ }
+ }
+
+
+ /* Test for specific pseudovector types. */
+
+ LISP_INLINE bool
+ WINDOW_CONFIGURATIONP (Lisp_Object a)
+ {
+ return PSEUDOVECTORP (a, PVEC_WINDOW_CONFIGURATION);
+ }
+
+ LISP_INLINE bool
+ PROCESSP (Lisp_Object a)
+ {
+ return PSEUDOVECTORP (a, PVEC_PROCESS);
+ }
LISP_INLINE bool
- SAVE_VALUEP (Lisp_Object x)
+ WINDOWP (Lisp_Object a)
{
- return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value;
+ return PSEUDOVECTORP (a, PVEC_WINDOW);
}
- LISP_INLINE struct Lisp_Save_Value *
- XSAVE_VALUE (Lisp_Object a)
+ LISP_INLINE bool
+ TERMINALP (Lisp_Object a)
{
- eassert (SAVE_VALUEP (a));
- return & XMISC (a)->u_save_value;
+ return PSEUDOVECTORP (a, PVEC_TERMINAL);
}
- /* Return the type of V's Nth saved value. */
- LISP_INLINE int
- save_type (struct Lisp_Save_Value *v, int n)
+ LISP_INLINE bool
+ SUBRP (Lisp_Object a)
{
- eassert (0 <= n && n < SAVE_VALUE_SLOTS);
- return (v->save_type >> (SAVE_SLOT_BITS * n) & ((1 << SAVE_SLOT_BITS) - 1));
+ return PSEUDOVECTORP (a, PVEC_SUBR);
}
- /* Get and set the Nth saved pointer. */
-
- LISP_INLINE void *
- XSAVE_POINTER (Lisp_Object obj, int n)
+ LISP_INLINE bool
+ COMPILEDP (Lisp_Object a)
{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER);
- return XSAVE_VALUE (obj)->data[n].pointer;;
+ return PSEUDOVECTORP (a, PVEC_COMPILED);
}
- LISP_INLINE void
- set_save_pointer (Lisp_Object obj, int n, void *val)
+
+ LISP_INLINE bool
+ BUFFERP (Lisp_Object a)
{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER);
- XSAVE_VALUE (obj)->data[n].pointer = val;
+ return PSEUDOVECTORP (a, PVEC_BUFFER);
}
- /* Likewise for the saved integer. */
-
- LISP_INLINE ptrdiff_t
- XSAVE_INTEGER (Lisp_Object obj, int n)
+ LISP_INLINE bool
+ CHAR_TABLE_P (Lisp_Object a)
{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER);
- return XSAVE_VALUE (obj)->data[n].integer;
+ return PSEUDOVECTORP (a, PVEC_CHAR_TABLE);
}
- LISP_INLINE void
- set_save_integer (Lisp_Object obj, int n, ptrdiff_t val)
+
+ LISP_INLINE bool
+ SUB_CHAR_TABLE_P (Lisp_Object a)
{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER);
- XSAVE_VALUE (obj)->data[n].integer = val;
+ return PSEUDOVECTORP (a, PVEC_SUB_CHAR_TABLE);
}
- /* Extract Nth saved object. */
-
- LISP_INLINE Lisp_Object
- XSAVE_OBJECT (Lisp_Object obj, int n)
+ LISP_INLINE bool
+ BOOL_VECTOR_P (Lisp_Object a)
{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_OBJECT);
- return XSAVE_VALUE (obj)->data[n].object;
+ return PSEUDOVECTORP (a, PVEC_BOOL_VECTOR);
}
- #define AUTOLOADP(x) (CONSP (x) && EQ (Qautoload, XCAR (x)))
-
- #define INTFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Int)
- #define BOOLFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Bool)
- #define OBJFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Obj)
- #define BUFFER_OBJFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Buffer_Obj)
- #define KBOARD_OBJFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Kboard_Obj)
-
- /* True if object X is a pseudovector whose code is CODE. The cast to struct
- vectorlike_header * avoids aliasing issues. */
- #define PSEUDOVECTORP(x, code) \
- TYPED_PSEUDOVECTORP (x, vectorlike_header, code)
+ LISP_INLINE bool
+ FRAMEP (Lisp_Object a)
+ {
+ return PSEUDOVECTORP (a, PVEC_FRAME);
+ }
- #define PSEUDOVECTOR_TYPEP(v, code) \
- (((v)->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
- == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)))
++LISP_INLINE bool
++THREADP (Lisp_Object a)
++{
++ return PSEUDOVECTORP (a, PVEC_THREAD);
++}
+
- /* True if object X, with internal type struct T *, is a pseudovector whose
- code is CODE. */
- #define TYPED_PSEUDOVECTORP(x, t, code) \
- (VECTORLIKEP (x) \
- && PSEUDOVECTOR_TYPEP ((struct t *) XUNTAG (x, Lisp_Vectorlike), code))
++LISP_INLINE bool
++MUTEXP (Lisp_Object a)
++{
++ return PSEUDOVECTORP (a, PVEC_MUTEX);
++}
+
- /* Test for specific pseudovector types. */
- #define WINDOW_CONFIGURATIONP(x) PSEUDOVECTORP (x, PVEC_WINDOW_CONFIGURATION)
- #define PROCESSP(x) PSEUDOVECTORP (x, PVEC_PROCESS)
- #define WINDOWP(x) PSEUDOVECTORP (x, PVEC_WINDOW)
- #define TERMINALP(x) PSEUDOVECTORP (x, PVEC_TERMINAL)
- #define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR)
- #define COMPILEDP(x) PSEUDOVECTORP (x, PVEC_COMPILED)
- #define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER)
- #define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE)
- #define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE)
- #define BOOL_VECTOR_P(x) PSEUDOVECTORP (x, PVEC_BOOL_VECTOR)
- #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME)
- #define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD)
- #define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX)
- #define CONDVARP(x) PSEUDOVECTORP (x, PVEC_CONDVAR)
++LISP_INLINE bool
++CONDVARP (Lisp_Object a)
++{
++ return PSEUDOVECTORP (a, PVEC_CONDVAR);
++}
+
/* Test for image (image . spec) */
- #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage))
+ LISP_INLINE bool
+ IMAGEP (Lisp_Object x)
+ {
+ return CONSP (x) && EQ (XCAR (x), Qimage);
+ }
/* Array types. */
-
- #define ARRAYP(x) \
- (VECTORP (x) || STRINGP (x) || CHAR_TABLE_P (x) || BOOL_VECTOR_P (x))
+ LISP_INLINE bool
+ ARRAYP (Lisp_Object x)
+ {
+ return VECTORP (x) || STRINGP (x) || CHAR_TABLE_P (x) || BOOL_VECTOR_P (x);
+ }
\f
- #define CHECK_LIST(x) \
- CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x)
-
- #define CHECK_LIST_CONS(x, y) \
- CHECK_TYPE (CONSP (x), Qlistp, y)
-
- #define CHECK_LIST_END(x, y) \
- CHECK_TYPE (NILP (x), Qlistp, y)
-
- #define CHECK_STRING(x) \
- CHECK_TYPE (STRINGP (x), Qstringp, x)
-
- #define CHECK_STRING_CAR(x) \
- CHECK_TYPE (STRINGP (XCAR (x)), Qstringp, XCAR (x))
-
- #define CHECK_CONS(x) \
- CHECK_TYPE (CONSP (x), Qconsp, x)
-
- #define CHECK_SYMBOL(x) \
- CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
-
- #define CHECK_CHAR_TABLE(x) \
- CHECK_TYPE (CHAR_TABLE_P (x), Qchar_table_p, x)
-
- #define CHECK_VECTOR(x) \
- CHECK_TYPE (VECTORP (x), Qvectorp, x)
-
- #define CHECK_VECTOR_OR_STRING(x) \
- CHECK_TYPE (VECTORP (x) || STRINGP (x), Qarrayp, x)
-
- #define CHECK_ARRAY(x, Qxxxp) \
- CHECK_TYPE (ARRAYP (x), Qxxxp, x)
-
- #define CHECK_VECTOR_OR_CHAR_TABLE(x) \
- CHECK_TYPE (VECTORP (x) || CHAR_TABLE_P (x), Qvector_or_char_table_p, x)
-
- #define CHECK_BUFFER(x) \
- CHECK_TYPE (BUFFERP (x), Qbufferp, x)
-
- #define CHECK_WINDOW(x) \
- CHECK_TYPE (WINDOWP (x), Qwindowp, x)
-
- #define CHECK_WINDOW_CONFIGURATION(x) \
- CHECK_TYPE (WINDOW_CONFIGURATIONP (x), Qwindow_configuration_p, x)
-
- #define CHECK_PROCESS(x) \
- CHECK_TYPE (PROCESSP (x), Qprocessp, x)
-
- #define CHECK_SUBR(x) \
- CHECK_TYPE (SUBRP (x), Qsubrp, x)
+ LISP_INLINE void
+ CHECK_LIST (Lisp_Object x)
+ {
+ CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x);
+ }
- #define CHECK_NUMBER(x) \
- CHECK_TYPE (INTEGERP (x), Qintegerp, x)
+ LISP_MACRO_DEFUN_VOID (CHECK_LIST_CONS, (Lisp_Object x, Lisp_Object y), (x, y))
+ LISP_MACRO_DEFUN_VOID (CHECK_SYMBOL, (Lisp_Object x), (x))
+ LISP_MACRO_DEFUN_VOID (CHECK_NUMBER, (Lisp_Object x), (x))
- #define CHECK_NATNUM(x) \
- CHECK_TYPE (NATNUMP (x), Qwholenump, x)
+ LISP_INLINE void
+ CHECK_STRING (Lisp_Object x)
+ {
+ CHECK_TYPE (STRINGP (x), Qstringp, x);
+ }
+ LISP_INLINE void
+ CHECK_STRING_CAR (Lisp_Object x)
+ {
+ CHECK_TYPE (STRINGP (XCAR (x)), Qstringp, XCAR (x));
+ }
+ LISP_INLINE void
+ CHECK_CONS (Lisp_Object x)
+ {
+ CHECK_TYPE (CONSP (x), Qconsp, x);
+ }
+ LISP_INLINE void
+ CHECK_VECTOR (Lisp_Object x)
+ {
+ CHECK_TYPE (VECTORP (x), Qvectorp, x);
+ }
+ LISP_INLINE void
+ CHECK_VECTOR_OR_STRING (Lisp_Object x)
+ {
+ CHECK_TYPE (VECTORP (x) || STRINGP (x), Qarrayp, x);
+ }
+ LISP_INLINE void
+ CHECK_ARRAY (Lisp_Object x, Lisp_Object Qxxxp)
+ {
+ CHECK_TYPE (ARRAYP (x), Qxxxp, x);
+ }
+ LISP_INLINE void
+ CHECK_BUFFER (Lisp_Object x)
+ {
+ CHECK_TYPE (BUFFERP (x), Qbufferp, x);
+ }
+ LISP_INLINE void
+ CHECK_WINDOW (Lisp_Object x)
+ {
+ CHECK_TYPE (WINDOWP (x), Qwindowp, x);
+ }
+ LISP_INLINE void
+ CHECK_PROCESS (Lisp_Object x)
+ {
+ CHECK_TYPE (PROCESSP (x), Qprocessp, x);
+ }
+ LISP_INLINE void
+ CHECK_NATNUM (Lisp_Object x)
+ {
+ CHECK_TYPE (NATNUMP (x), Qwholenump, x);
+ }
#define CHECK_RANGED_INTEGER(x, lo, hi) \
do { \
do { if (MARKERP (x)) XSETFASTINT (x, marker_position (x)); \
else CHECK_TYPE (INTEGERP (x) || FLOATP (x), Qnumber_or_marker_p, x); } while (0)
- #define CHECK_OVERLAY(x) \
- CHECK_TYPE (OVERLAYP (x), Qoverlayp, x)
+
- #define CHECK_THREAD(x) \
- CHECK_TYPE (THREADP (x), Qthreadp, x)
++LISP_INLINE void
++CHECK_THREAD (Lisp_Object x)
++{
++ CHECK_TYPE (THREADP (x), Qthreadp, x);
++}
+
- #define CHECK_MUTEX(x) \
- CHECK_TYPE (MUTEXP (x), Qmutexp, x)
++LISP_INLINE void
++CHECK_MUTEX (Lisp_Object x)
++{
++ CHECK_TYPE (MUTEXP (x), Qmutexp, x);
++}
+
- #define CHECK_CONDVAR(x) \
- CHECK_TYPE (CONDVARP (x), Qcondition_variablep, x)
++LISP_INLINE void
++CHECK_CONDVAR (Lisp_Object x)
++{
++ CHECK_TYPE (CONDVARP (x), Qcondition_variablep, x);
++}
+
/* Since we can't assign directly to the CAR or CDR fields of a cons
cell, use these when checking that those fields contain numbers. */
- #define CHECK_NUMBER_CAR(x) \
- do { \
- Lisp_Object tmp = XCAR (x); \
- CHECK_NUMBER (tmp); \
- XSETCAR ((x), tmp); \
- } while (0)
-
- #define CHECK_NUMBER_CDR(x) \
- do { \
- Lisp_Object tmp = XCDR (x); \
- CHECK_NUMBER (tmp); \
- XSETCDR ((x), tmp); \
- } while (0)
-
- #define CHECK_NATNUM_CAR(x) \
- do { \
- Lisp_Object tmp = XCAR (x); \
- CHECK_NATNUM (tmp); \
- XSETCAR ((x), tmp); \
- } while (0)
+ LISP_INLINE void
+ CHECK_NUMBER_CAR (Lisp_Object x)
+ {
+ Lisp_Object tmp = XCAR (x);
+ CHECK_NUMBER (tmp);
+ XSETCAR (x, tmp);
+ }
- #define CHECK_NATNUM_CDR(x) \
- do { \
- Lisp_Object tmp = XCDR (x); \
- CHECK_NATNUM (tmp); \
- XSETCDR ((x), tmp); \
- } while (0)
+ LISP_INLINE void
+ CHECK_NUMBER_CDR (Lisp_Object x)
+ {
+ Lisp_Object tmp = XCDR (x);
+ CHECK_NUMBER (tmp);
+ XSETCDR (x, tmp);
+ }
\f
/* Define a built-in function for calling from Lisp.
`lname' should be the name to give the function in Lisp,
SPECPDL_LET_DEFAULT /* A global binding for a localized var. */
};
- struct specbinding
+ union specbinding
{
- enum specbind_tag kind;
- union {
- struct {
- Lisp_Object arg;
- specbinding_func func;
- } unwind;
- struct {
- /* `where' is not used in the case of SPECPDL_LET. */
- Lisp_Object symbol, old_value, where;
- /* Normally this is unused; but it is set to the symbol's
- current value when a thread is swapped out. */
- Lisp_Object saved_value;
- } let;
- struct {
- Lisp_Object function;
- Lisp_Object *args;
- ptrdiff_t nargs : BITS_PER_PTRDIFF_T - 1;
- bool debug_on_exit : 1;
- } bt;
- } v;
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ struct {
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ Lisp_Object arg;
+ specbinding_func func;
+ } unwind;
+ struct {
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ /* `where' is not used in the case of SPECPDL_LET. */
+ Lisp_Object symbol, old_value, where;
++ /* Normally this is unused; but it is set to the symbol's
++ current value when a thread is swapped out. */
++ Lisp_Object saved_value;
+ } let;
+ struct {
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ bool debug_on_exit : 1;
+ Lisp_Object function;
+ Lisp_Object *args;
+ ptrdiff_t nargs;
+ } bt;
};
- LISP_INLINE Lisp_Object specpdl_symbol (struct specbinding *pdl)
- { eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.symbol; }
-
- LISP_INLINE Lisp_Object specpdl_old_value (struct specbinding *pdl)
- { eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.old_value; }
-
- LISP_INLINE Lisp_Object specpdl_saved_value (struct specbinding *pdl)
- { eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.saved_value; }
-
- LISP_INLINE Lisp_Object specpdl_where (struct specbinding *pdl)
- { eassert (pdl->kind > SPECPDL_LET); return pdl->v.let.where; }
-
- LISP_INLINE Lisp_Object specpdl_arg (struct specbinding *pdl)
- { eassert (pdl->kind == SPECPDL_UNWIND); return pdl->v.unwind.arg; }
-
- LISP_INLINE specbinding_func specpdl_func (struct specbinding *pdl)
- { eassert (pdl->kind == SPECPDL_UNWIND); return pdl->v.unwind.func; }
-
- LISP_INLINE Lisp_Object backtrace_function (struct specbinding *pdl)
- { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.function; }
-
- LISP_INLINE ptrdiff_t backtrace_nargs (struct specbinding *pdl)
- { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.nargs; }
-
- LISP_INLINE Lisp_Object *backtrace_args (struct specbinding *pdl)
- { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.args; }
-
- LISP_INLINE bool backtrace_debug_on_exit (struct specbinding *pdl)
- { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.debug_on_exit; }
-
- /* extern struct specbinding *specpdl; */
- /* extern struct specbinding *specpdl_ptr; */
-extern union specbinding *specpdl;
-extern union specbinding *specpdl_ptr;
-extern ptrdiff_t specpdl_size;
++/* extern union specbinding *specpdl; */
++/* extern union specbinding *specpdl_ptr; */
+/* extern ptrdiff_t specpdl_size; */
- #define SPECPDL_INDEX() (specpdl_ptr - specpdl)
+ LISP_INLINE ptrdiff_t
+ SPECPDL_INDEX (void)
+ {
+ return specpdl_ptr - specpdl;
+ }
/* Everything needed to describe an active condition case.
extern void syms_of_eval (void);
extern void record_in_backtrace (Lisp_Object function,
Lisp_Object *args, ptrdiff_t nargs);
- extern void mark_specpdl (struct specbinding *first, struct specbinding *ptr);
-extern void mark_specpdl (void);
++extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
extern void get_backtrace (Lisp_Object array);
Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
/* When lisp.h is not included Lisp_Object is not defined (this can
happen when this files is used outside the src directory).
-- Use GCPRO1 to determine if lisp.h was included. */
--#ifdef GCPRO1
++ Use GCTYPEBITS to determine if lisp.h was included. */
++#ifdef GCTYPEBITS
/* defined in editfns.c */
extern Lisp_Object make_lisp_time (EMACS_TIME);
extern bool decode_time_components (Lisp_Object, Lisp_Object, Lisp_Object,
--- /dev/null
- new_thread->m_specpdl = xmalloc (new_thread->m_specpdl_size
- * sizeof (struct specbinding));
+/* Threading code.
+ Copyright (C) 2012, 2013 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/>. */
+
+
+#include <config.h>
+#include <setjmp.h>
+#include "lisp.h"
+#include "character.h"
+#include "buffer.h"
+#include "process.h"
+#include "coding.h"
+
+static struct thread_state primary_thread;
+
+struct thread_state *current_thread = &primary_thread;
+
+static struct thread_state *all_threads = &primary_thread;
+
+static sys_mutex_t global_lock;
+
+Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep;
+
+\f
+
+/* m_specpdl is set when the thread is created and cleared when the
+ thread dies. */
+#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
+
+\f
+
+static void
+release_global_lock (void)
+{
+ sys_mutex_unlock (&global_lock);
+}
+
+/* You must call this after acquiring the global lock.
+ acquire_global_lock does it for you. */
+static void
+post_acquire_global_lock (struct thread_state *self)
+{
+ Lisp_Object buffer;
+
+ if (self != current_thread)
+ {
+ /* CURRENT_THREAD is NULL if the previously current thread
+ exited. In this case, there is no reason to unbind, and
+ trying will crash. */
+ if (current_thread != NULL)
+ unbind_for_thread_switch ();
+ current_thread = self;
+ rebind_for_thread_switch ();
+ }
+
+ /* We need special handling to re-set the buffer. */
+ XSETBUFFER (buffer, self->m_current_buffer);
+ self->m_current_buffer = 0;
+ set_buffer_internal (XBUFFER (buffer));
+
+ if (!NILP (current_thread->error_symbol))
+ {
+ Lisp_Object sym = current_thread->error_symbol;
+ Lisp_Object data = current_thread->error_data;
+
+ current_thread->error_symbol = Qnil;
+ current_thread->error_data = Qnil;
+ Fsignal (sym, data);
+ }
+}
+
+static void
+acquire_global_lock (struct thread_state *self)
+{
+ sys_mutex_lock (&global_lock);
+ post_acquire_global_lock (self);
+}
+
+\f
+
+static void
+lisp_mutex_init (lisp_mutex_t *mutex)
+{
+ mutex->owner = NULL;
+ mutex->count = 0;
+ sys_cond_init (&mutex->condition);
+}
+
+static int
+lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+{
+ struct thread_state *self;
+
+ if (mutex->owner == NULL)
+ {
+ mutex->owner = current_thread;
+ mutex->count = new_count == 0 ? 1 : new_count;
+ return 0;
+ }
+ if (mutex->owner == current_thread)
+ {
+ eassert (new_count == 0);
+ ++mutex->count;
+ return 0;
+ }
+
+ self = current_thread;
+ self->wait_condvar = &mutex->condition;
+ while (mutex->owner != NULL && (new_count != 0
+ || NILP (self->error_symbol)))
+ sys_cond_wait (&mutex->condition, &global_lock);
+ self->wait_condvar = NULL;
+
+ if (new_count == 0 && !NILP (self->error_symbol))
+ return 1;
+
+ mutex->owner = self;
+ mutex->count = new_count == 0 ? 1 : new_count;
+
+ return 1;
+}
+
+static int
+lisp_mutex_unlock (lisp_mutex_t *mutex)
+{
+ struct thread_state *self = current_thread;
+
+ if (mutex->owner != current_thread)
+ error ("blah");
+
+ if (--mutex->count > 0)
+ return 0;
+
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return 1;
+}
+
+static unsigned int
+lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
+{
+ struct thread_state *self = current_thread;
+ unsigned int result = mutex->count;
+
+ /* Ensured by condvar code. */
+ eassert (mutex->owner == current_thread);
+
+ mutex->count = 0;
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return result;
+}
+
+static void
+lisp_mutex_destroy (lisp_mutex_t *mutex)
+{
+ sys_cond_destroy (&mutex->condition);
+}
+
+static int
+lisp_mutex_owned_p (lisp_mutex_t *mutex)
+{
+ return mutex->owner == current_thread;
+}
+
+\f
+
+DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
+ doc: /* Create a mutex.
+A mutex provides a synchronization point for threads.
+Only one thread at a time can hold a mutex. Other threads attempting
+to acquire it will block until the mutex is available.
+
+A thread can acquire a mutex any number of times.
+
+NAME, if given, is used as the name of the mutex. The name is
+informational only. */)
+ (Lisp_Object name)
+{
+ struct Lisp_Mutex *mutex;
+ Lisp_Object result;
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+ memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
+ 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
+ mutex));
+ mutex->name = name;
+ lisp_mutex_init (&mutex->mutex);
+
+ XSETMUTEX (result, mutex);
+ return result;
+}
+
+static void
+mutex_lock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_lock (&mutex->mutex, 0))
+ post_acquire_global_lock (self);
+}
+
+static Lisp_Object
+do_unwind_mutex_lock (Lisp_Object ignore)
+{
+ current_thread->event_object = Qnil;
+ return Qnil;
+}
+
+DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+ doc: /* Acquire a mutex.
+If the current thread already owns MUTEX, increment the count and
+return.
+Otherwise, if no thread owns MUTEX, make the current thread own it.
+Otherwise, block until MUTEX is available, or until the current thread
+is signalled using `thread-signal'.
+Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ current_thread->event_object = mutex;
+ record_unwind_protect (do_unwind_mutex_lock, Qnil);
+ flush_stack_call_func (mutex_lock_callback, lmutex);
+ return unbind_to (count, Qnil);
+}
+
+static void
+mutex_unlock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_unlock (&mutex->mutex))
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+ doc: /* Release the mutex.
+If this thread does not own MUTEX, signal an error.
+Otherwise, decrement the mutex's count. If the count is zero,
+release MUTEX. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ flush_stack_call_func (mutex_unlock_callback, lmutex);
+ return Qnil;
+}
+
+DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
+ doc: /* Return the name of MUTEX.
+If no name was given when MUTEX was created, return nil. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ return lmutex->name;
+}
+
+void
+finalize_one_mutex (struct Lisp_Mutex *mutex)
+{
+ lisp_mutex_destroy (&mutex->mutex);
+}
+
+\f
+
+DEFUN ("make-condition-variable",
+ Fmake_condition_variable, Smake_condition_variable,
+ 1, 2, 0,
+ doc: /* Make a condition variable.
+A condition variable provides a way for a thread to sleep while
+waiting for a state change.
+
+MUTEX is the mutex associated with this condition variable.
+NAME, if given, is the name of this condition variable. The name is
+informational only. */)
+ (Lisp_Object mutex, Lisp_Object name)
+{
+ struct Lisp_CondVar *condvar;
+ Lisp_Object result;
+
+ CHECK_MUTEX (mutex);
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+ memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
+ 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
+ cond));
+ condvar->mutex = mutex;
+ condvar->name = name;
+ sys_cond_init (&condvar->cond);
+
+ XSETCONDVAR (result, condvar);
+ return result;
+}
+
+static void
+condition_wait_callback (void *arg)
+{
+ struct Lisp_CondVar *cvar = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, cvar);
+ self->event_object = cond;
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ /* If we were signalled while unlocking, we skip the wait, but we
+ still must reacquire our lock. */
+ if (NILP (self->error_symbol))
+ {
+ self->wait_condvar = &cvar->cond;
+ sys_cond_wait (&cvar->cond, &global_lock);
+ self->wait_condvar = NULL;
+ }
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
+ doc: /* Wait for the condition variable to be notified.
+CONDITION is the condition variable to wait on.
+
+The mutex associated with CONDITION must be held when this is called.
+It is an error if it is not held.
+
+This releases the mutex and waits for CONDITION to be notified or for
+this thread to be signalled with `thread-signal'. When
+`condition-wait' returns, the mutex will again be locked by this
+thread. */)
+ (Lisp_Object condition)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("fixme");
+
+ flush_stack_call_func (condition_wait_callback, cvar);
+
+ return Qnil;
+}
+
+/* Used to communicate argumnets to condition_notify_callback. */
+struct notify_args
+{
+ struct Lisp_CondVar *cvar;
+ int all;
+};
+
+static void
+condition_notify_callback (void *arg)
+{
+ struct notify_args *na = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, na->cvar);
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ if (na->all)
+ sys_cond_broadcast (&na->cvar->cond);
+ else
+ sys_cond_signal (&na->cvar->cond);
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
+ doc: /* Notify a condition variable.
+This wakes a thread waiting on CONDITION.
+If ALL is non-nil, all waiting threads are awoken.
+
+The mutex associated with CONDITION must be held when this is called.
+It is an error if it is not held.
+
+This releases the mutex when notifying CONDITION. When
+`condition-notify' returns, the mutex will again be locked by this
+thread. */)
+ (Lisp_Object condition, Lisp_Object all)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+ struct notify_args args;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("fixme");
+
+ args.cvar = cvar;
+ args.all = !NILP (all);
+ flush_stack_call_func (condition_notify_callback, &args);
+
+ return Qnil;
+}
+
+DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
+ doc: /* Return the mutex associated with CONDITION. */)
+ (Lisp_Object condition)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ return cvar->mutex;
+}
+
+DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
+ doc: /* Return the name of CONDITION.
+If no name was given when CONDITION was created, return nil. */)
+ (Lisp_Object condition)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ return cvar->name;
+}
+
+void
+finalize_one_condvar (struct Lisp_CondVar *condvar)
+{
+ sys_cond_destroy (&condvar->cond);
+}
+
+\f
+
+struct select_args
+{
+ select_func *func;
+ int max_fds;
+ SELECT_TYPE *rfds;
+ SELECT_TYPE *wfds;
+ SELECT_TYPE *efds;
+ EMACS_TIME *timeout;
+ sigset_t *sigmask;
+ int result;
+};
+
+static void
+really_call_select (void *arg)
+{
+ struct select_args *sa = arg;
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
+ sa->timeout, sa->sigmask);
+ acquire_global_lock (self);
+}
+
+int
+thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout,
+ sigset_t *sigmask)
+{
+ struct select_args sa;
+
+ sa.func = func;
+ sa.max_fds = max_fds;
+ sa.rfds = rfds;
+ sa.wfds = wfds;
+ sa.efds = efds;
+ sa.timeout = timeout;
+ sa.sigmask = sigmask;
+ flush_stack_call_func (really_call_select, &sa);
+ return sa.result;
+}
+
+\f
+
+static void
+mark_one_thread (struct thread_state *thread)
+{
+ struct handler *handler;
+ Lisp_Object tem;
+
+ mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
+
+#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
+ || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
+ mark_stack (thread->m_stack_bottom, thread->stack_top);
+#else
+ {
+ struct gcpro *tail;
+ for (tail = thread->m_gcprolist; tail; tail = tail->next)
+ for (i = 0; i < tail->nvars; i++)
+ mark_object (tail->var[i]);
+ }
+
+#if BYTE_MARK_STACK
+ if (thread->m_byte_stack_list)
+ mark_byte_stack (thread->m_byte_stack_list);
+#endif
+
+ mark_catchlist (thread->m_catchlist);
+
+ for (handler = thread->m_handlerlist; handler; handler = handler->next)
+ {
+ mark_object (handler->handler);
+ mark_object (handler->var);
+ }
+#endif
+
+ if (thread->m_current_buffer)
+ {
+ XSETBUFFER (tem, thread->m_current_buffer);
+ mark_object (tem);
+ }
+
+ mark_object (thread->m_last_thing_searched);
+
+ if (thread->m_saved_last_thing_searched)
+ mark_object (thread->m_saved_last_thing_searched);
+}
+
+static void
+mark_threads_callback (void *ignore)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ Lisp_Object thread_obj;
+
+ XSETTHREAD (thread_obj, iter);
+ mark_object (thread_obj);
+ mark_one_thread (iter);
+ }
+}
+
+void
+mark_threads (void)
+{
+ flush_stack_call_func (mark_threads_callback, NULL);
+}
+
+void
+unmark_threads (void)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ if (iter->m_byte_stack_list)
+ unmark_byte_stack (iter->m_byte_stack_list);
+}
+
+\f
+
+static void
+yield_callback (void *ignore)
+{
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sys_thread_yield ();
+ acquire_global_lock (self);
+}
+
+DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
+ doc: /* Yield the CPU to another thread. */)
+ (void)
+{
+ flush_stack_call_func (yield_callback, NULL);
+ return Qnil;
+}
+
+static Lisp_Object
+invoke_thread_function (void)
+{
+ Lisp_Object iter;
+ volatile struct thread_state *self = current_thread;
+
+ int count = SPECPDL_INDEX ();
+
+ Ffuncall (1, ¤t_thread->function);
+ return unbind_to (count, Qnil);
+}
+
+static Lisp_Object
+do_nothing (Lisp_Object whatever)
+{
+ return whatever;
+}
+
+static void *
+run_thread (void *state)
+{
+ char stack_pos;
+ struct thread_state *self = state;
+ struct thread_state **iter;
+
+ self->m_stack_bottom = &stack_pos;
+ self->stack_top = &stack_pos;
+ self->thread_id = sys_thread_self ();
+
+ acquire_global_lock (self);
+
+ /* It might be nice to do something with errors here. */
+ internal_condition_case (invoke_thread_function, Qt, do_nothing);
+
+ update_processes_for_thread_death (Fcurrent_thread ());
+
+ xfree (self->m_specpdl);
+ self->m_specpdl = NULL;
+ self->m_specpdl_ptr = NULL;
+ self->m_specpdl_size = 0;
+
+ current_thread = NULL;
+ sys_cond_broadcast (&self->thread_condvar);
+
+ /* Unlink this thread from the list of all threads. Note that we
+ have to do this very late, after broadcasting our death.
+ Otherwise the GC may decide to reap the thread_state object,
+ leading to crashes. */
+ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+ ;
+ *iter = (*iter)->next_thread;
+
+ release_global_lock ();
+
+ return NULL;
+}
+
+void
+finalize_one_thread (struct thread_state *state)
+{
+ sys_cond_destroy (&state->thread_condvar);
+}
+
+DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
+ doc: /* Start a new thread and run FUNCTION in it.
+When the function exits, the thread dies.
+If NAME is given, it names the new thread. */)
+ (Lisp_Object function, Lisp_Object name)
+{
+ sys_thread_t thr;
+ struct thread_state *new_thread;
+ Lisp_Object result;
+ const char *c_name = NULL;
+
+ /* Can't start a thread in temacs. */
+ if (!initialized)
+ abort ();
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist,
+ PVEC_THREAD);
+ memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist),
+ 0, sizeof (struct thread_state) - offsetof (struct thread_state,
+ m_gcprolist));
+
+ new_thread->function = function;
+ new_thread->name = name;
+ new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
+ new_thread->m_saved_last_thing_searched = Qnil;
+ new_thread->m_current_buffer = current_thread->m_current_buffer;
+ new_thread->error_symbol = Qnil;
+ new_thread->error_data = Qnil;
+ new_thread->event_object = Qnil;
+
+ new_thread->m_specpdl_size = 50;
++ new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
++ * sizeof (union specbinding));
++ /* Skip the dummy entry. */
++ ++new_thread->m_specpdl;
+ new_thread->m_specpdl_ptr = new_thread->m_specpdl;
+
+ sys_cond_init (&new_thread->thread_condvar);
+
+ /* We'll need locking here eventually. */
+ new_thread->next_thread = all_threads;
+ all_threads = new_thread;
+
+ if (!NILP (name))
+ c_name = SSDATA (ENCODE_UTF_8 (name));
+
+ if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
+ {
+ /* Restore the previous situation. */
+ all_threads = all_threads->next_thread;
+ error ("Could not start a new thread");
+ }
+
+ /* FIXME: race here where new thread might not be filled in? */
+ XSETTHREAD (result, new_thread);
+ return result;
+}
+
+DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
+ doc: /* Return the current thread. */)
+ (void)
+{
+ Lisp_Object result;
+ XSETTHREAD (result, current_thread);
+ return result;
+}
+
+DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
+ doc: /* Return the name of the THREAD.
+The name is the same object that was passed to `make-thread'. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->name;
+}
+
+static void
+thread_signal_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+
+ sys_cond_broadcast (tstate->wait_condvar);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
+ doc: /* Signal an error in a thread.
+This acts like `signal', but arranges for the signal to be raised
+in THREAD. If THREAD is the current thread, acts just like `signal'.
+This will interrupt a blocked call to `mutex-lock', `condition-wait',
+or `thread-join' in the target thread. */)
+ (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ Fsignal (error_symbol, data);
+
+ /* What to do if thread is already signalled? */
+ /* What if error_symbol is Qnil? */
+ tstate->error_symbol = error_symbol;
+ tstate->error_data = data;
+
+ if (tstate->wait_condvar)
+ flush_stack_call_func (thread_signal_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
+ doc: /* Return t if THREAD is alive, or nil if it has exited. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return thread_alive_p (tstate) ? Qt : Qnil;
+}
+
+DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
+ doc: /* Return the object that THREAD is blocking on.
+If THREAD is blocked in `thread-join' on a second thread, return that
+thread.
+If THREAD is blocked in `mutex-lock', return the mutex.
+If THREAD is blocked in `condition-wait', return the condition variable.
+Otherwise, if THREAD is not blocked, return nil. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->event_object;
+}
+
+static void
+thread_join_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, tstate);
+ self->event_object = thread;
+ self->wait_condvar = &tstate->thread_condvar;
+ while (tstate->m_specpdl != NULL && NILP (self->error_symbol))
+ sys_cond_wait (self->wait_condvar, &global_lock);
+
+ self->wait_condvar = NULL;
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
+ doc: /* Wait for a thread to exit.
+This blocks the current thread until THREAD exits.
+It is an error for a thread to try to join itself. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ error ("cannot join current thread");
+
+ if (tstate->m_specpdl != NULL)
+ flush_stack_call_func (thread_join_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
+ doc: /* Return a list of all threads. */)
+ (void)
+{
+ Lisp_Object result = Qnil;
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (thread_alive_p (iter))
+ {
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, iter);
+ result = Fcons (thread, result);
+ }
+ }
+
+ return result;
+}
+
+\f
+
+int
+thread_check_current_buffer (struct buffer *buffer)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (iter == current_thread)
+ continue;
+
+ if (iter->m_current_buffer == buffer)
+ return 1;
+ }
+
+ return 0;
+}
+
+\f
+
+static void
+init_primary_thread (void)
+{
+ primary_thread.header.size
+ = PSEUDOVECSIZE (struct thread_state, m_gcprolist);
+ XSETPVECTYPE (&primary_thread, PVEC_THREAD);
+ primary_thread.m_last_thing_searched = Qnil;
+ primary_thread.m_saved_last_thing_searched = Qnil;
+ primary_thread.name = Qnil;
+ primary_thread.function = Qnil;
+ primary_thread.error_symbol = Qnil;
+ primary_thread.error_data = Qnil;
+ primary_thread.event_object = Qnil;
+}
+
+void
+init_threads_once (void)
+{
+ init_primary_thread ();
+}
+
+void
+init_threads (void)
+{
+ init_primary_thread ();
+ sys_cond_init (&primary_thread.thread_condvar);
+ sys_mutex_init (&global_lock);
+ sys_mutex_lock (&global_lock);
+ current_thread = &primary_thread;
+ primary_thread.thread_id = sys_thread_self ();
+}
+
+void
+syms_of_threads (void)
+{
+ defsubr (&Sthread_yield);
+ defsubr (&Smake_thread);
+ defsubr (&Scurrent_thread);
+ defsubr (&Sthread_name);
+ defsubr (&Sthread_signal);
+ defsubr (&Sthread_alive_p);
+ defsubr (&Sthread_join);
+ defsubr (&Sthread_blocker);
+ defsubr (&Sall_threads);
+ defsubr (&Smake_mutex);
+ defsubr (&Smutex_lock);
+ defsubr (&Smutex_unlock);
+ defsubr (&Smutex_name);
+ defsubr (&Smake_condition_variable);
+ defsubr (&Scondition_wait);
+ defsubr (&Scondition_notify);
+ defsubr (&Scondition_mutex);
+ defsubr (&Scondition_name);
+
+ Qthreadp = intern_c_string ("threadp");
+ staticpro (&Qthreadp);
+ Qmutexp = intern_c_string ("mutexp");
+ staticpro (&Qmutexp);
+ Qcondition_variablep = intern_c_string ("condition-variablep");
+ staticpro (&Qcondition_variablep);
+}
--- /dev/null
- struct specbinding *m_specpdl;
+/* Thread definitions
+ Copyright (C) 2012, 2013 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/>. */
+
+#ifndef THREAD_H
+#define THREAD_H
+
+#include "regex.h"
+
+#include "sysselect.h" /* FIXME */
+#include "systime.h" /* FIXME */
+
+struct thread_state
+{
+ struct vectorlike_header header;
+
+ /* The buffer in which the last search was performed, or
+ Qt if the last search was done in a string;
+ Qnil if no searching has been done yet. */
+ Lisp_Object m_last_thing_searched;
+#define last_thing_searched (current_thread->m_last_thing_searched)
+
+ Lisp_Object m_saved_last_thing_searched;
+#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
+
+ /* The thread's name. */
+ Lisp_Object name;
+
+ /* The thread's function. */
+ Lisp_Object function;
+
+ /* If non-nil, this thread has been signalled. */
+ Lisp_Object error_symbol;
+ Lisp_Object error_data;
+
+ /* If we are waiting for some event, this holds the object we are
+ waiting on. */
+ Lisp_Object event_object;
+
+ /* m_gcprolist must be the first non-lisp field. */
+ /* Recording what needs to be marked for gc. */
+ struct gcpro *m_gcprolist;
+#define gcprolist (current_thread->m_gcprolist)
+
+ /* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removed the entry again when it is
+ done. Signalling an error truncates the list analoguous to
+ gcprolist. */
+ struct byte_stack *m_byte_stack_list;
+#define byte_stack_list (current_thread->m_byte_stack_list)
+
+ /* An address near the bottom of the stack.
+ Tells GC how to save a copy of the stack. */
+ char *m_stack_bottom;
+#define stack_bottom (current_thread->m_stack_bottom)
+
+ /* An address near the top of the stack. */
+ char *stack_top;
+
+ struct catchtag *m_catchlist;
+#define catchlist (current_thread->m_catchlist)
+
+ /* Chain of condition handlers currently in effect.
+ The elements of this chain are contained in the stack frames
+ of Fcondition_case and internal_condition_case.
+ When an error is signaled (by calling Fsignal, below),
+ this chain is searched for an element that applies. */
+ struct handler *m_handlerlist;
+#define handlerlist (current_thread->m_handlerlist)
+
+ /* Count levels of GCPRO to detect failure to UNGCPRO. */
+ int m_gcpro_level;
+#define gcpro_level (current_thread->m_gcpro_level)
+
+ /* Current number of specbindings allocated in specpdl. */
+ ptrdiff_t m_specpdl_size;
+#define specpdl_size (current_thread->m_specpdl_size)
+
+ /* Pointer to beginning of specpdl. */
- struct specbinding *m_specpdl_ptr;
++ union specbinding *m_specpdl;
+#define specpdl (current_thread->m_specpdl)
+
+ /* Pointer to first unused element in specpdl. */
++ union specbinding *m_specpdl_ptr;
+#define specpdl_ptr (current_thread->m_specpdl_ptr)
+
+ /* Depth in Lisp evaluations and function calls. */
+ EMACS_INT m_lisp_eval_depth;
+#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
+
+ /* This points to the current buffer. */
+ struct buffer *m_current_buffer;
+#define current_buffer (current_thread->m_current_buffer)
+
+ /* Every call to re_match, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_match
+ is certainly going to be called again before region-around-match
+ can be called).
+
+ Since the registers are now dynamically allocated, we need to make
+ sure not to refer to the Nth register before checking that it has
+ been allocated by checking search_regs.num_regs.
+
+ The regex code keeps track of whether it has allocated the search
+ buffer using bits in the re_pattern_buffer. This means that whenever
+ you compile a new pattern, it completely forgets whether it has
+ allocated any registers, and will allocate new registers the next
+ time you call a searching or matching function. Therefore, we need
+ to call re_set_registers after compiling a new pattern or after
+ setting the match registers, so that the regex functions will be
+ able to free or re-allocate it properly. */
+ struct re_registers m_search_regs;
+#define search_regs (current_thread->m_search_regs)
+
+ /* If non-zero the match data have been saved in saved_search_regs
+ during the execution of a sentinel or filter. */
+ bool m_search_regs_saved;
+#define search_regs_saved (current_thread->m_search_regs_saved)
+
+ struct re_registers m_saved_search_regs;
+#define saved_search_regs (current_thread->m_saved_search_regs)
+
+ /* This is the string or buffer in which we
+ are matching. It is used for looking up syntax properties. */
+ Lisp_Object m_re_match_object;
+#define re_match_object (current_thread->m_re_match_object)
+
+ /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
+ also be assigned to arbitrarily: each pattern buffer stores its own
+ syntax, so it can be changed between regex compilations. */
+ reg_syntax_t m_re_syntax_options;
+#define re_syntax_options (current_thread->m_re_syntax_options)
+
+ /* Regexp to use to replace spaces, or NULL meaning don't. */
+ /*re_char*/ unsigned char *m_whitespace_regexp;
+#define whitespace_regexp (current_thread->m_whitespace_regexp)
+
+ /* This variable is different from waiting_for_input in keyboard.c.
+ It is used to communicate to a lisp process-filter/sentinel (via the
+ function Fwaiting_for_user_input_p) whether Emacs was waiting
+ for user-input when that process-filter was called.
+ waiting_for_input cannot be used as that is by definition 0 when
+ lisp code is being evalled.
+ This is also used in record_asynch_buffer_change.
+ For that purpose, this must be 0
+ when not inside wait_reading_process_output. */
+ int m_waiting_for_user_input_p;
+#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
+
+ /* The OS identifier for this thread. */
+ sys_thread_t thread_id;
+
+ /* The condition variable for this thread. This is associated with
+ the global lock. This thread broadcasts to it when it exits. */
+ sys_cond_t thread_condvar;
+
+ /* This thread might be waiting for some condition. If so, this
+ points to the condition. If the thread is interrupted, the
+ interrupter should broadcast to this condition. */
+ sys_cond_t *wait_condvar;
+
+ /* Threads are kept on a linked list. */
+ struct thread_state *next_thread;
+};
+
+/* A mutex in lisp is represented by a system condition variable.
+ The system mutex associated with this condition variable is the
+ global lock.
+
+ Using a condition variable lets us implement interruptibility for
+ lisp mutexes. */
+typedef struct
+{
+ /* The owning thread, or NULL if unlocked. */
+ struct thread_state *owner;
+ /* The lock count. */
+ unsigned int count;
+ /* The underlying system condition variable. */
+ sys_cond_t condition;
+} lisp_mutex_t;
+
+/* A mutex as a lisp object. */
+struct Lisp_Mutex
+{
+ struct vectorlike_header header;
+
+ /* The name of the mutex, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level mutex object. */
+ lisp_mutex_t mutex;
+};
+
+/* A condition variable as a lisp object. */
+struct Lisp_CondVar
+{
+ struct vectorlike_header header;
+
+ /* The associated mutex. */
+ Lisp_Object mutex;
+
+ /* The name of the condition variable, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level condition variable object. */
+ sys_cond_t cond;
+};
+
+extern struct thread_state *current_thread;
+
+extern void unmark_threads (void);
+extern void finalize_one_thread (struct thread_state *state);
+extern void finalize_one_mutex (struct Lisp_Mutex *);
+extern void finalize_one_condvar (struct Lisp_CondVar *);
+
+extern void init_threads_once (void);
+extern void init_threads (void);
+extern void syms_of_threads (void);
+
+typedef int select_func (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
+ EMACS_TIME *, sigset_t *);
+
+int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout,
+ sigset_t *sigmask);
+
+int thread_check_current_buffer (struct buffer *);
+
+#endif /* THREAD_H */
projects / emacs.git / commitdiff