Re: set-process-plist equivalent in XEmacs?

Ar an naoú lá is fiche de mí Lúnasa, scríobh Adam Sjøgren: If we can actually trust the documentation, this should do for Gnus’ purposes: (defvar process-plist-map (make-hash-table :test 'eq :weakness 'key) "Property list information for process, when XEmacs doesn't provide this. See `process-plist' and `set-process-plist'.") (defun-when-void process-plist (process) "Return the property list of PROCESS." (check-argument-type #'processp process) (gethash process process-plist-map)) (defun-when-void set-process-plist (process plist) "Set the property list of PROCESS to PLIST." (check-argument-type #'processp process) (check-argument-type #'valid-plist-p plist) (puthash process plist process-plist-map)) Within XEmacs, we need to do something more like the following: diff -r db84c9d41437 lisp/obsolete.el --- a/lisp/obsolete.el Thu Aug 26 22:45:58 2010 -0400 +++ b/lisp/obsolete.el Sun Aug 29 18:01:40 2010 +0100 ＠＠ -428,5 +428,8 ＠＠ (define-function 'purecopy 'identity) (make-obsolete 'purecopy "purespace is not available in XEmacs.") +(define-compatible-function-alias 'process-plist 'object-plist) +(define-compatible-function-alias 'set-process-plist 'object-setplist) + (provide 'obsolete) ;;; obsolete.el ends here diff -r db84c9d41437 src/emacs.c --- a/src/emacs.c Thu Aug 26 22:45:58 2010 -0400 +++ b/src/emacs.c Sun Aug 29 18:01:40 2010 +0100 ＠＠ -1468,6 +1468,7 ＠＠ reinit_alloc_early (); reinit_gc_early (); reinit_symbols_early (); + reinit_process_early (); #ifndef NEW_GC reinit_opaque_early (); #endif /* not NEW_GC */ diff -r db84c9d41437 src/fns.c --- a/src/fns.c Thu Aug 26 22:45:58 2010 -0400 +++ b/src/fns.c Sun Aug 29 18:01:40 2010 +0100 ＠＠ -3612,6 +3612,25 ＠＠ return Qnil; } +DEFUN ("object-setplist", Fobject_setplist, 2, 2, 0, /* +Set OBJECT's property list to NEWPLIST, and return NEWPLIST. +For a symbol, this is equivalent to `setplist'. +OBJECT can be a symbol, string, extent, face, glyph, or process. +Do not modify the returned property list directly; +this may or may not have the desired effects. Use `put' instead. +*/ + (object, newplist)) +{ + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->setplist) + { + return XRECORD_LHEADER_IMPLEMENTATION (object)->setplist (object, newplist); + } + + invalid_operation ("Not possible to set object's plist", object); + return Qnil; +} + +  static Lisp_Object tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2, ＠＠ -5992,6 +6011,7 ＠＠ DEFSUBR (Fput); DEFSUBR (Fremprop); DEFSUBR (Fobject_plist); + DEFSUBR (Fobject_setplist); DEFSUBR (Fequal); DEFSUBR (Fequalp); DEFSUBR (Fold_equal); diff -r db84c9d41437 src/lrecord.h --- a/src/lrecord.h Thu Aug 26 22:45:58 2010 -0400 +++ b/src/lrecord.h Sun Aug 29 18:01:40 2010 +0100 ＠＠ -525,6 +525,7 ＠＠ int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val); int (*remprop) (Lisp_Object obj, Lisp_Object prop); Lisp_Object (*plist) (Lisp_Object obj); + Lisp_Object (*setplist) (Lisp_Object obj, Lisp_Object newplist); /* `disksave' is called at dump time. It is used for objects that contain pointers or handles to objects created in external libraries, diff -r db84c9d41437 src/process-slots.h --- a/src/process-slots.h Thu Aug 26 22:45:58 2010 -0400 +++ b/src/process-slots.h Sun Aug 29 18:01:40 2010 +0100 ＠＠ -68,4 +68,6 ＠＠ all of the Lisp objects, including in process-type-specific data. */ MARKED_SLOT (tty_name) + MARKED_SLOT (plist) + #undef MARKED_SLOT diff -r db84c9d41437 src/process.c --- a/src/process.c Thu Aug 26 22:45:58 2010 -0400 +++ b/src/process.c Sun Aug 29 18:01:40 2010 +0100 ＠＠ -170,6 +170,40 ＠＠ write_ascstring (printcharfun, ">"); } } +/* Process plists are directly accessible, so we need to protect against + invalid property list structure */ + +static Lisp_Object +process_getprop (Lisp_Object process, Lisp_Object property) +{ + return external_plist_get (&XPROCESS (process)->plist, property, 0, ERROR_ME); +} + +static int +process_putprop (Lisp_Object process, Lisp_Object property, Lisp_Object value) +{ + external_plist_put (&XPROCESS (process)->plist, property, value, 0, ERROR_ME); + return 1; +} + +static int +process_remprop (Lisp_Object process, Lisp_Object property) +{ + return external_remprop (&XPROCESS (process)->plist, property, 0, ERROR_ME); +} + +static Lisp_Object +process_plist (Lisp_Object process) +{ + return XPROCESS (process)->plist; +} + +static Lisp_Object +process_setplist (Lisp_Object process, Lisp_Object newplist) +{ + XPROCESS (process)->plist = newplist; + return newplist; +} #ifdef HAVE_WINDOW_SYSTEM extern void debug_process_finalization (Lisp_Process *p); ＠＠ -2405,6 +2439,16 ＠＠ }  +void +reinit_process_early (void) +{ + OBJECT_HAS_METHOD (process, getprop); + OBJECT_HAS_METHOD (process, putprop); + OBJECT_HAS_METHOD (process, remprop); + OBJECT_HAS_METHOD (process, plist); + OBJECT_HAS_METHOD (process, setplist); +} + /* This is not named init_process in order to avoid a conflict with NS 3.3 */ void init_xemacs_process (void) ＠＠ -2481,6 +2525,8 ＠＠ Vshell_file_name = build_istring (shell); } + + reinit_process_early (); } void -- “Apart from the nine-banded armadillo, man is the only natural host of Mycobacterium leprae, although it can be grown in the footpads of mice.” -- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research _______________________________________________ XEmacs-Beta mailing list XEmacs-Beta(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-beta