Add new User Pointer (User_Ptr) type

* src/lisp.h: Add new Lisp_Misc_User_Ptr type.
(XUSER_PTR): New User_Ptr accessor.
* src/alloc.c (make_user_ptr): New function.
(mark_object, sweep_misc): Handle Lisp_Misc_User_Ptr.
* src/data.c (Ftype_of): Return 'user-ptr' for user pointer.
(Fuser-ptrp): New user pointer type predicate function.
(syms_of_data): New 'user-ptrp', 'user-ptr' symbol.  New 'user-ptrp'
subr.
* src/print.c (print_object): Add printer for User_Ptr type.
This commit is contained in:
Aurélien Aptel 2015-11-16 00:42:14 +01:00 committed by Ted Zlatanov
parent 435cf35bcc
commit f69cd6bfa1
4 changed files with 115 additions and 1 deletions

View file

@ -3711,6 +3711,23 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
}
}
#ifdef HAVE_MODULES
/* Create a new module user ptr object. */
Lisp_Object
make_user_ptr (void (*finalizer) (void*), void *p)
{
Lisp_Object obj;
struct Lisp_User_Ptr *uptr;
obj = allocate_misc (Lisp_Misc_User_Ptr);
uptr = XUSER_PTR (obj);
uptr->finalizer = finalizer;
uptr->p = p;
return obj;
}
#endif
static void
init_finalizer_list (struct Lisp_Finalizer *head)
{
@ -6301,6 +6318,12 @@ mark_object (Lisp_Object arg)
mark_object (XFINALIZER (obj)->function);
break;
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
XMISCANY (obj)->gcmarkbit = true;
break;
#endif
default:
emacs_abort ();
}
@ -6677,8 +6700,15 @@ sweep_misc (void)
{
if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
unchain_marker (&mblk->markers[i].m.u_marker);
if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
unchain_finalizer (&mblk->markers[i].m.u_finalizer);
#ifdef HAVE_MODULES
else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr)
{
struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr;
uptr->finalizer (uptr->p);
}
#endif
/* Set the type of the freed object to Lisp_Misc_Free.
We could leave the type alone, since nobody checks it,
but this might catch bugs faster. */

View file

@ -223,6 +223,10 @@ for example, (type-of 1) returns `integer'. */)
return Qfloat;
case Lisp_Misc_Finalizer:
return Qfinalizer;
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
return Quser_ptr;
#endif
default:
emacs_abort ();
}
@ -424,6 +428,17 @@ DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
return Qnil;
}
#ifdef HAVE_MODULES
DEFUN ("user-ptrp", Fuser_ptrp, Suser_ptrp, 1, 1, 0,
doc: /* Return t if OBJECT is a module user pointer. */)
(Lisp_Object object)
{
if (USER_PTRP (object))
return Qt;
return Qnil;
}
#endif
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
doc: /* Return t if OBJECT is a built-in function. */)
(Lisp_Object object)
@ -3478,6 +3493,9 @@ syms_of_data (void)
DEFSYM (Qbool_vector_p, "bool-vector-p");
DEFSYM (Qchar_or_string_p, "char-or-string-p");
DEFSYM (Qmarkerp, "markerp");
#ifdef HAVE_MODULES
DEFSYM (Quser_ptrp, "user-ptrp");
#endif
DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
DEFSYM (Qfboundp, "fboundp");
@ -3569,6 +3587,9 @@ syms_of_data (void)
DEFSYM (Qmarker, "marker");
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
#ifdef HAVE_MODULES
DEFSYM (Quser_ptr, "user-ptr");
#endif
DEFSYM (Qfloat, "float");
DEFSYM (Qwindow_configuration, "window-configuration");
DEFSYM (Qprocess, "process");
@ -3683,6 +3704,9 @@ syms_of_data (void)
defsubr (&Sbyteorder);
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
#ifdef HAVE_MODULES
defsubr (&Suser_ptrp);
#endif
defsubr (&Sbool_vector_exclusive_or);
defsubr (&Sbool_vector_union);

View file

@ -468,6 +468,9 @@ enum Lisp_Misc_Type
Lisp_Misc_Overlay,
Lisp_Misc_Save_Value,
Lisp_Misc_Finalizer,
#ifdef HAVE_MODULES
Lisp_Misc_User_Ptr,
#endif
/* Currently floats are not a misc type,
but let's define this in case we want to change that. */
Lisp_Misc_Float,
@ -581,6 +584,12 @@ INLINE bool PROCESSP (Lisp_Object);
INLINE bool PSEUDOVECTORP (Lisp_Object, int);
INLINE bool SAVE_VALUEP (Lisp_Object);
INLINE bool FINALIZERP (Lisp_Object);
#ifdef HAVE_MODULES
INLINE bool USER_PTRP (Lisp_Object);
INLINE struct Lisp_User_Ptr *(XUSER_PTR) (Lisp_Object);
#endif
INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
Lisp_Object);
INLINE bool STRINGP (Lisp_Object);
@ -2230,6 +2239,18 @@ XSAVE_OBJECT (Lisp_Object obj, int n)
return XSAVE_VALUE (obj)->data[n].object;
}
#ifdef HAVE_MODULES
struct Lisp_User_Ptr
{
ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_User_Ptr */
bool_bf gcmarkbit : 1;
unsigned spacer : 15;
void (*finalizer) (void*);
void *p;
};
#endif
/* A finalizer sentinel. */
struct Lisp_Finalizer
{
@ -2265,6 +2286,9 @@ union Lisp_Misc
struct Lisp_Overlay u_overlay;
struct Lisp_Save_Value u_save_value;
struct Lisp_Finalizer u_finalizer;
#ifdef HAVE_MODULES
struct Lisp_User_Ptr u_user_ptr;
#endif
};
INLINE union Lisp_Misc *
@ -2314,6 +2338,16 @@ XFINALIZER (Lisp_Object a)
return & XMISC (a)->u_finalizer;
}
#ifdef HAVE_MODULES
INLINE struct Lisp_User_Ptr *
XUSER_PTR (Lisp_Object a)
{
eassert (USER_PTRP (a));
return & XMISC (a)->u_user_ptr;
}
#endif
/* Forwarding pointer to an int variable.
This is allowed only in the value cell of a symbol,
@ -2598,6 +2632,14 @@ FINALIZERP (Lisp_Object x)
return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer;
}
#ifdef HAVE_MODULES
INLINE bool
USER_PTRP (Lisp_Object x)
{
return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_User_Ptr;
}
#endif
INLINE bool
AUTOLOADP (Lisp_Object x)
{
@ -3870,6 +3912,11 @@ Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
extern bool let_shadows_global_binding_p (Lisp_Object symbol);
#ifdef HAVE_MODULES
/* Defined in alloc.c. */
extern Lisp_Object make_user_ptr (void (*finalizer) (void*), void *p);
#endif
/* Defined in editfns.c. */
extern void insert1 (Lisp_Object);

View file

@ -1990,6 +1990,19 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
printchar ('>', printcharfun);
break;
#ifdef HAVE_MODULES
case Lisp_Misc_User_Ptr:
{
print_c_string ("#<user-ptr ", printcharfun);
int i = sprintf (buf, "ptr=%p finalizer=%p",
XUSER_PTR (obj)->p,
XUSER_PTR (obj)->finalizer);
strout (buf, i, i, printcharfun);
printchar ('>', printcharfun);
break;
}
#endif
case Lisp_Misc_Finalizer:
print_c_string ("#<finalizer", printcharfun);
if (NILP (XFINALIZER (obj)->function))