September 2010 - XEmacs-Patches - XEmacs Mailing List Archives

[COMMIT] Do the right thing with control, meta characters, #'kbd 14 years, 3 months

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. xemacs-packages/xemacs-base/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * edmacro.el (edmacro-parse-word): If we're handed control or meta characters in WORD, return appropriate lists (in the canonical form) with ((control X)) or ((meta X)) instead of the character itself (which is non-canonical). Also, if handed an octal escape, error if it wouldn't represent a valid character, and parse it in the same way if it does represent a valid character. XEmacs Packages source patch: Diff command: cvs -q diff -Nu Files affected: xemacs-packages/xemacs-base/edmacro.el Index: xemacs-packages/xemacs-base/edmacro.el =================================================================== RCS file: /cvsroot/xemacs/XEmacs/packages/xemacs-packages/xemacs-base/edmacro.el,v retrieving revision 1.3 diff -u -r1.3 edmacro.el --- xemacs-packages/xemacs-base/edmacro.el 27 Nov 1999 20:49:53 -0000 1.3 +++ xemacs-packages/xemacs-base/edmacro.el 2 Sep 2010 14:21:54 -0000 ＠＠ -499,11 +499,12 ＠＠ arg)))) (add (cond - ((string-match "^\\\\[0-7]+" word) - ;; Octal value of character. - (list - (edmacro-int-char - (hexl-octal-string-to-integer (substring word 1))))) + ((prog1 nil + (string-match "^\\\\[0-7]\\{1,3\\}$" word) + ;; Octal value of a character. If it's numerically out of + ;; range, allow the Lisp reader to error. If read succedds, + ;; we handle the actual numeric value further down. + (setq word (read (concat "\"" word "\""))))) ((string-match "^<<.+>>$" word) ;; Extended command. (nconc ＠＠ -547,6 +548,20 ＠＠ ;; because of the way `edmacro-format-keys' works. (mapcar 'identity word) (list (nconc (nreverse r1) (list (funcall conv follow))))))) + ((string-match "^[\x00-\x1f]$" word) + ;; Bug; we can't do this for \C-m, \C-j, \C-i, because + ;; edmacro-parse-keys, above, treats this as whitespace. + `((control + ,(intern (downcase (concat (list (+ (aref word 0) ?＠)) + nil)))))) + ((string-match "^[\x80-\xff]$" word) + `((meta ,＠(if (< (aref word 0) #xa0) + `(control ,(intern (downcase + (concat (list (- (aref word 0) + ?＠)) nil)))) + `(,(intern (downcase (concat + (list (- (aref word 0) #x80)) + nil)))))))) (force-sym ;; This must be a symbol (list (intern word))) -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

[COMMIT] Support process plists, for greater GNU compatibility. 14 years, 3 months

Aidan Kehoe

Adam, this won’t make a big difference to you, but it should make things a little easier for people porting code in the future. APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1283426591 -3600 # Node ID b5611afbcc76ccadea91257e34d9c609632c1750 # Parent 1537701f08a15ed8fc904f04a5a3fdf3e5ec0bed Support process plists, for greater GNU compatibility. src/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * process.c (process_getprop, process_putprop, process_remprop) (process_plist, process_setplist, reinit_process_early): Add functions to modify a process's property list. * process-slots.h (MARKED_SLOT): Add a plist slot. * fns.c (Fobject_setplist): New function, analogous to #'setplist, but more general. Update the documentation in the other plist functions to reflect that processes now have property lists. * emacs.c (main_1): Call reinit_process_early(), now processes have plist methods that need to be initialised. * symbols.c (reinit_symbol_objects_early): Fsetplist is the named setplist method for symbols. lisp/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * obsolete.el (process-get): Make #'process-get, #'process-put, #'process-plist, #'set-process-plist available as aliases to the more general functions #'get, #'put, #'object-plist, #'object-setplist, for GNU compatibility. diff -r 1537701f08a1 -r b5611afbcc76 lisp/ChangeLog --- a/lisp/ChangeLog Thu Sep 02 12:00:06 2010 +0100 +++ b/lisp/ChangeLog Thu Sep 02 12:23:11 2010 +0100 ＠＠ -1,3 +1,11 ＠＠ +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * obsolete.el (process-get): + Make #'process-get, #'process-put, #'process-plist, + #'set-process-plist available as aliases to the more general + functions #'get, #'put, #'object-plist, #'object-setplist, for GNU + compatibility. + 2010-08-20 Mike Sperber <mike(a)xemacs.org> * files.el (save-some-buffers-action-alist): Add. diff -r 1537701f08a1 -r b5611afbcc76 lisp/obsolete.el --- a/lisp/obsolete.el Thu Sep 02 12:00:06 2010 +0100 +++ b/lisp/obsolete.el Thu Sep 02 12:23:11 2010 +0100 ＠＠ -428,5 +428,10 ＠＠ (define-function 'purecopy 'identity) (make-obsolete 'purecopy "purespace is not available in XEmacs.") +(define-compatible-function-alias 'process-get 'get) +(define-compatible-function-alias 'process-put 'put) +(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 1537701f08a1 -r b5611afbcc76 src/ChangeLog --- a/src/ChangeLog Thu Sep 02 12:00:06 2010 +0100 +++ b/src/ChangeLog Thu Sep 02 12:23:11 2010 +0100 ＠＠ -39,6 +39,22 ＠＠ (Fmaplist, Fmapl, Fmapcon): Call maplist() with its new arguments. +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * process.c (process_getprop, process_putprop, process_remprop) + (process_plist, process_setplist, reinit_process_early): + Add functions to modify a process's property list. + * process-slots.h (MARKED_SLOT): Add a plist slot. + + * fns.c (Fobject_setplist): New function, analogous to #'setplist, + but more general. + Update the documentation in the other plist functions to reflect + that processes now have property lists. + * emacs.c (main_1): Call reinit_process_early(), now processes have + plist methods that need to be initialised. + * symbols.c (reinit_symbol_objects_early): Fsetplist is the named + setplist method for symbols. + 2010-08-30 Aidan Kehoe <kehoea(a)parhasard.net> * floatfns.c (ceiling_one_mundane_arg, floor_one_mundane_arg) diff -r 1537701f08a1 -r b5611afbcc76 src/emacs.c --- a/src/emacs.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/emacs.c Thu Sep 02 12:23:11 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 1537701f08a1 -r b5611afbcc76 src/fns.c --- a/src/fns.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/fns.c Thu Sep 02 12:23:11 2010 +0100 ＠＠ -3545,7 +3545,8 ＠＠ This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. If there is no such property, return optional third arg DEFAULT \(which defaults to `nil'). OBJECT can be a symbol, string, extent, -face, or glyph. See also `put', `remprop', and `object-plist'. +face, glyph, or process. See also `put', `remprop', `object-plist', and +`object-setplist'. */ (object, property, default_)) { ＠＠ -3589,9 +3590,10 ＠＠ DEFUN ("remprop", Fremprop, 2, 2, 0, /* Remove, from OBJECT's property list, PROPERTY and its corresponding value. -OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil -if the property list was actually modified (i.e. if PROPERTY was present -in the property list). See also `get', `put', and `object-plist'. +OBJECT can be a symbol, string, extent, face, glyph, or process. +Return non-nil if the property list was actually modified (i.e. if PROPERTY +was present in the property list). See also `get', `put', `object-plist', +and `object-setplist'. */ (object, property)) { ＠＠ -3628,6 +3630,26 ＠＠ 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 or a process, other objects with visible plists do +not allow their modification with `object-setplist'. +*/ + (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, ＠＠ -6015,6 +6037,7 ＠＠ DEFSUBR (Fput); DEFSUBR (Fremprop); DEFSUBR (Fobject_plist); + DEFSUBR (Fobject_setplist); DEFSUBR (Fequal); DEFSUBR (Fequalp); DEFSUBR (Fold_equal); diff -r 1537701f08a1 -r b5611afbcc76 src/lrecord.h --- a/src/lrecord.h Thu Sep 02 12:00:06 2010 +0100 +++ b/src/lrecord.h Thu Sep 02 12:23:11 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 1537701f08a1 -r b5611afbcc76 src/process-slots.h --- a/src/process-slots.h Thu Sep 02 12:00:06 2010 +0100 +++ b/src/process-slots.h Thu Sep 02 12:23:11 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 1537701f08a1 -r b5611afbcc76 src/process.c --- a/src/process.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/process.c Thu Sep 02 12:23:11 2010 +0100 ＠＠ -170,6 +170,42 ＠＠ 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 +2441,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 +2527,8 ＠＠ Vshell_file_name = build_istring (shell); } + + reinit_process_early (); } void diff -r 1537701f08a1 -r b5611afbcc76 src/symbols.c --- a/src/symbols.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/symbols.c Thu Sep 02 12:23:11 2010 +0100 ＠＠ -3530,6 +3530,7 ＠＠ OBJECT_HAS_METHOD (symbol, putprop); OBJECT_HAS_METHOD (symbol, remprop); OBJECT_HAS_NAMED_METHOD (symbol, plist, Fsymbol_plist); + OBJECT_HAS_NAMED_METHOD (symbol, setplist, Fsetplist); } 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-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

commit: Support process plists, for greater GNU compatibility. 14 years, 3 months

Aidan Kehoe

changeset: 5255:b5611afbcc76 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net> date: Thu Sep 02 12:23:11 2010 +0100 files: lisp/ChangeLog lisp/obsolete.el src/ChangeLog src/emacs.c src/fns.c src/lrecord.h src/process-slots.h src/process.c src/symbols.c description: Support process plists, for greater GNU compatibility. src/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * process.c (process_getprop, process_putprop, process_remprop) (process_plist, process_setplist, reinit_process_early): Add functions to modify a process's property list. * process-slots.h (MARKED_SLOT): Add a plist slot. * fns.c (Fobject_setplist): New function, analogous to #'setplist, but more general. Update the documentation in the other plist functions to reflect that processes now have property lists. * emacs.c (main_1): Call reinit_process_early(), now processes have plist methods that need to be initialised. * symbols.c (reinit_symbol_objects_early): Fsetplist is the named setplist method for symbols. lisp/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * obsolete.el (process-get): Make #'process-get, #'process-put, #'process-plist, #'set-process-plist available as aliases to the more general functions #'get, #'put, #'object-plist, #'object-setplist, for GNU compatibility. diff -r 1537701f08a1 -r b5611afbcc76 lisp/ChangeLog --- a/lisp/ChangeLog Thu Sep 02 12:00:06 2010 +0100 +++ b/lisp/ChangeLog Thu Sep 02 12:23:11 2010 +0100 ＠＠ -1,3 +1,11 ＠＠ +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * obsolete.el (process-get): + Make #'process-get, #'process-put, #'process-plist, + #'set-process-plist available as aliases to the more general + functions #'get, #'put, #'object-plist, #'object-setplist, for GNU + compatibility. + 2010-08-20 Mike Sperber <mike(a)xemacs.org> * files.el (save-some-buffers-action-alist): Add. diff -r 1537701f08a1 -r b5611afbcc76 lisp/obsolete.el --- a/lisp/obsolete.el Thu Sep 02 12:00:06 2010 +0100 +++ b/lisp/obsolete.el Thu Sep 02 12:23:11 2010 +0100 ＠＠ -428,5 +428,10 ＠＠ (define-function 'purecopy 'identity) (make-obsolete 'purecopy "purespace is not available in XEmacs.") +(define-compatible-function-alias 'process-get 'get) +(define-compatible-function-alias 'process-put 'put) +(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 1537701f08a1 -r b5611afbcc76 src/ChangeLog --- a/src/ChangeLog Thu Sep 02 12:00:06 2010 +0100 +++ b/src/ChangeLog Thu Sep 02 12:23:11 2010 +0100 ＠＠ -38,6 +38,22 ＠＠ case, despite what the comments said. (Fmaplist, Fmapl, Fmapcon): Call maplist() with its new arguments. + +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * process.c (process_getprop, process_putprop, process_remprop) + (process_plist, process_setplist, reinit_process_early): + Add functions to modify a process's property list. + * process-slots.h (MARKED_SLOT): Add a plist slot. + + * fns.c (Fobject_setplist): New function, analogous to #'setplist, + but more general. + Update the documentation in the other plist functions to reflect + that processes now have property lists. + * emacs.c (main_1): Call reinit_process_early(), now processes have + plist methods that need to be initialised. + * symbols.c (reinit_symbol_objects_early): Fsetplist is the named + setplist method for symbols. 2010-08-30 Aidan Kehoe <kehoea(a)parhasard.net> diff -r 1537701f08a1 -r b5611afbcc76 src/emacs.c --- a/src/emacs.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/emacs.c Thu Sep 02 12:23:11 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 1537701f08a1 -r b5611afbcc76 src/fns.c --- a/src/fns.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/fns.c Thu Sep 02 12:23:11 2010 +0100 ＠＠ -3545,7 +3545,8 ＠＠ This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. If there is no such property, return optional third arg DEFAULT \(which defaults to `nil'). OBJECT can be a symbol, string, extent, -face, or glyph. See also `put', `remprop', and `object-plist'. +face, glyph, or process. See also `put', `remprop', `object-plist', and +`object-setplist'. */ (object, property, default_)) { ＠＠ -3589,9 +3590,10 ＠＠ DEFUN ("remprop", Fremprop, 2, 2, 0, /* Remove, from OBJECT's property list, PROPERTY and its corresponding value. -OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil -if the property list was actually modified (i.e. if PROPERTY was present -in the property list). See also `get', `put', and `object-plist'. +OBJECT can be a symbol, string, extent, face, glyph, or process. +Return non-nil if the property list was actually modified (i.e. if PROPERTY +was present in the property list). See also `get', `put', `object-plist', +and `object-setplist'. */ (object, property)) { ＠＠ -3627,6 +3629,26 ＠＠ 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 or a process, other objects with visible plists do +not allow their modification with `object-setplist'. +*/ + (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 ＠＠ -6015,6 +6037,7 ＠＠ DEFSUBR (Fput); DEFSUBR (Fremprop); DEFSUBR (Fobject_plist); + DEFSUBR (Fobject_setplist); DEFSUBR (Fequal); DEFSUBR (Fequalp); DEFSUBR (Fold_equal); diff -r 1537701f08a1 -r b5611afbcc76 src/lrecord.h --- a/src/lrecord.h Thu Sep 02 12:00:06 2010 +0100 +++ b/src/lrecord.h Thu Sep 02 12:23:11 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 1537701f08a1 -r b5611afbcc76 src/process-slots.h --- a/src/process-slots.h Thu Sep 02 12:00:06 2010 +0100 +++ b/src/process-slots.h Thu Sep 02 12:23:11 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 1537701f08a1 -r b5611afbcc76 src/process.c --- a/src/process.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/process.c Thu Sep 02 12:23:11 2010 +0100 ＠＠ -169,6 +169,42 ＠＠ MAYBE_PROCMETH (print_process_data, (process, printcharfun)); 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 ＠＠ -2405,6 +2441,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 +2527,8 ＠＠ Vshell_file_name = build_istring (shell); } + + reinit_process_early (); } void diff -r 1537701f08a1 -r b5611afbcc76 src/symbols.c --- a/src/symbols.c Thu Sep 02 12:00:06 2010 +0100 +++ b/src/symbols.c Thu Sep 02 12:23:11 2010 +0100 ＠＠ -3530,6 +3530,7 ＠＠ OBJECT_HAS_METHOD (symbol, putprop); OBJECT_HAS_METHOD (symbol, remprop); OBJECT_HAS_NAMED_METHOD (symbol, plist, Fsymbol_plist); + OBJECT_HAS_NAMED_METHOD (symbol, setplist, Fsetplist); } void _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

commit: Support Roman month numbers, #'format-time-string 14 years, 3 months

Aidan Kehoe

changeset: 5254:1537701f08a1 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net> date: Thu Sep 02 12:00:06 2010 +0100 files: man/ChangeLog man/lispref/os.texi src/ChangeLog src/editfns.c src/strftime.c src/text.h description: Support Roman month numbers, #'format-time-string src/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * strftime.c (roman_upper, roman_lower, strftime): Implement Roman month numbers, as used in central and eastern Europe. * editfns.c (Fformat_time_string): Document two new escapes, to allow uppercase and lowercase Roman month numbers. Remove documentation of a bug that we didn't actually have. * text.h (Qtime_function_encoding): We know the text encoding coming from strftime(), because we always use the one in strftime.c. Don't use Qnative. man/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * lispref/os.texi (Time Conversion): Document the new #'format-time-string flags for Roman month numbers. diff -r b6a398dbb403 -r 1537701f08a1 man/ChangeLog --- a/man/ChangeLog Wed Sep 01 12:51:32 2010 +0100 +++ b/man/ChangeLog Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1,3 +1,9 ＠＠ +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * lispref/os.texi (Time Conversion): + Document the new #'format-time-string flags for Roman month + numbers. + 2010-08-30 Aidan Kehoe <kehoea(a)parhasard.net> * lispref/eval.texi (Evaluation, Multiple values): diff -r b6a398dbb403 -r 1537701f08a1 man/lispref/os.texi --- a/man/lispref/os.texi Wed Sep 01 12:51:32 2010 +0100 +++ b/man/lispref/os.texi Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1026,6 +1026,10 ＠＠ This stands for the year with century. ＠item %Z This stands for the time zone abbreviation. +＠item %\xe6 (the ISO-8859-1 lowercase ae character) +This stands for the month as a lowercase Roman number (i-xii) +＠item %\xc6 (the ISO-8859-1 uppercase AE character) +This stands for the month as an uppercase Roman number (I-XII) ＠end table ＠end defun diff -r b6a398dbb403 -r 1537701f08a1 src/ChangeLog --- a/src/ChangeLog Wed Sep 01 12:51:32 2010 +0100 +++ b/src/ChangeLog Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1,3 +1,16 ＠＠ +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * strftime.c (roman_upper, roman_lower, strftime): + Implement Roman month numbers, as used in central and eastern + Europe. + * editfns.c (Fformat_time_string): + Document two new escapes, to allow uppercase and lowercase Roman + month numbers. Remove documentation of a bug that we didn't + actually have. + * text.h (Qtime_function_encoding): We know the text encoding + coming from strftime(), because we always use the one in + strftime.c. Don't use Qnative. + 2010-09-01 Aidan Kehoe <kehoea(a)parhasard.net> * fns.c (list_merge, list_array_merge_into_list) diff -r b6a398dbb403 -r 1537701f08a1 src/editfns.c --- a/src/editfns.c Wed Sep 01 12:51:32 2010 +0100 +++ b/src/editfns.c Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1044,11 +1044,10 ＠＠ %Y is replaced by the year with century. %z is replaced by the time zone as a numeric offset (e.g +0530, -0800 etc.) %Z is replaced by the time zone abbreviation. +%\xe6 is replaced by the month as a lowercase Roman number (i-xii) +%\xc6 is replaced by the month as an uppercase Roman number (I-XII) The number of options reflects the `strftime' function. - -BUG: If the charset used by the current locale is not ISO 8859-1, the -characters appearing in the day and month names may be incorrect. */ (format_string, time_)) { diff -r b6a398dbb403 -r 1537701f08a1 src/strftime.c --- a/src/strftime.c Wed Sep 01 12:51:32 2010 +0100 +++ b/src/strftime.c Thu Sep 02 12:00:06 2010 +0100 ＠＠ -130,6 +130,16 ＠＠ { "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December" +}; + +static char const * const roman_upper[] = +{ + "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX", "X", "XI", "XII" +}; + +static char const * const roman_lower[] = +{ + "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix", "x", "xi", "xii" }; /* Add character C to STRING and increment LENGTH, ＠＠ -601,6 +611,16 ＠＠ add_num3 (&string[length], (1900 + tm->tm_year) % 1000, max - length, zero); break; + case '\xe6': + length += + add_str (&string[length], roman_lower[tm->tm_mon], + max - length); + break; + case '\xC6': + length += + add_str (&string[length], roman_upper[tm->tm_mon], + max - length); + break; } } } diff -r b6a398dbb403 -r 1537701f08a1 src/text.h --- a/src/text.h Wed Sep 01 12:51:32 2010 +0100 +++ b/src/text.h Thu Sep 02 12:00:06 2010 +0100 ＠＠ -3095,7 +3095,7 ＠＠ #endif #define Qunix_host_name_encoding Qnative #define Qunix_service_name_encoding Qnative -#define Qtime_function_encoding Qnative +#define Qtime_function_encoding Qbinary #define Qtime_zone_encoding Qtime_function_encoding #define Qmswindows_host_name_encoding Qmswindows_multibyte #define Qmswindows_service_name_encoding Qmswindows_multibyte _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

[COMMIT] Support Roman month numbers, #'format-time-string 14 years, 3 months

Aidan Kehoe

This change would be more useful in the C library, but I don’t have commit access there. APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1283425206 -3600 # Node ID 1537701f08a15ed8fc904f04a5a3fdf3e5ec0bed # Parent b6a398dbb40329f1f111c181692ab1be47c133cf Support Roman month numbers, #'format-time-string src/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * strftime.c (roman_upper, roman_lower, strftime): Implement Roman month numbers, as used in central and eastern Europe. * editfns.c (Fformat_time_string): Document two new escapes, to allow uppercase and lowercase Roman month numbers. Remove documentation of a bug that we didn't actually have. * text.h (Qtime_function_encoding): We know the text encoding coming from strftime(), because we always use the one in strftime.c. Don't use Qnative. man/ChangeLog addition: 2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> * lispref/os.texi (Time Conversion): Document the new #'format-time-string flags for Roman month numbers. diff -r b6a398dbb403 -r 1537701f08a1 man/ChangeLog --- a/man/ChangeLog Wed Sep 01 12:51:32 2010 +0100 +++ b/man/ChangeLog Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1,3 +1,9 ＠＠ +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * lispref/os.texi (Time Conversion): + Document the new #'format-time-string flags for Roman month + numbers. + 2010-08-30 Aidan Kehoe <kehoea(a)parhasard.net> * lispref/eval.texi (Evaluation, Multiple values): diff -r b6a398dbb403 -r 1537701f08a1 man/lispref/os.texi --- a/man/lispref/os.texi Wed Sep 01 12:51:32 2010 +0100 +++ b/man/lispref/os.texi Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1026,6 +1026,10 ＠＠ This stands for the year with century. ＠item %Z This stands for the time zone abbreviation. +＠item %\xe6 (the ISO-8859-1 lowercase ae character) +This stands for the month as a lowercase Roman number (i-xii) +＠item %\xc6 (the ISO-8859-1 uppercase AE character) +This stands for the month as an uppercase Roman number (I-XII) ＠end table ＠end defun diff -r b6a398dbb403 -r 1537701f08a1 src/ChangeLog --- a/src/ChangeLog Wed Sep 01 12:51:32 2010 +0100 +++ b/src/ChangeLog Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1,3 +1,16 ＠＠ +2010-09-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * strftime.c (roman_upper, roman_lower, strftime): + Implement Roman month numbers, as used in central and eastern + Europe. + * editfns.c (Fformat_time_string): + Document two new escapes, to allow uppercase and lowercase Roman + month numbers. Remove documentation of a bug that we didn't + actually have. + * text.h (Qtime_function_encoding): We know the text encoding + coming from strftime(), because we always use the one in + strftime.c. Don't use Qnative. + 2010-09-01 Aidan Kehoe <kehoea(a)parhasard.net> * fns.c (list_merge, list_array_merge_into_list) diff -r b6a398dbb403 -r 1537701f08a1 src/editfns.c --- a/src/editfns.c Wed Sep 01 12:51:32 2010 +0100 +++ b/src/editfns.c Thu Sep 02 12:00:06 2010 +0100 ＠＠ -1044,11 +1044,10 ＠＠ %Y is replaced by the year with century. %z is replaced by the time zone as a numeric offset (e.g +0530, -0800 etc.) %Z is replaced by the time zone abbreviation. +%\xe6 is replaced by the month as a lowercase Roman number (i-xii) +%\xc6 is replaced by the month as an uppercase Roman number (I-XII) The number of options reflects the `strftime' function. - -BUG: If the charset used by the current locale is not ISO 8859-1, the -characters appearing in the day and month names may be incorrect. */ (format_string, time_)) { diff -r b6a398dbb403 -r 1537701f08a1 src/strftime.c --- a/src/strftime.c Wed Sep 01 12:51:32 2010 +0100 +++ b/src/strftime.c Thu Sep 02 12:00:06 2010 +0100 ＠＠ -132,6 +132,16 ＠＠ "July", "August", "September", "October", "November", "December" }; +static char const * const roman_upper[] = +{ + "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX", "X", "XI", "XII" +}; + +static char const * const roman_lower[] = +{ + "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix", "x", "xi", "xii" +}; + /* Add character C to STRING and increment LENGTH, unless LENGTH would exceed MAX. */ ＠＠ -601,6 +611,16 ＠＠ add_num3 (&string[length], (1900 + tm->tm_year) % 1000, max - length, zero); break; + case '\xe6': + length += + add_str (&string[length], roman_lower[tm->tm_mon], + max - length); + break; + case '\xC6': + length += + add_str (&string[length], roman_upper[tm->tm_mon], + max - length); + break; } } } diff -r b6a398dbb403 -r 1537701f08a1 src/text.h --- a/src/text.h Wed Sep 01 12:51:32 2010 +0100 +++ b/src/text.h Thu Sep 02 12:00:06 2010 +0100 ＠＠ -3095,7 +3095,7 ＠＠ #endif #define Qunix_host_name_encoding Qnative #define Qunix_service_name_encoding Qnative -#define Qtime_function_encoding Qnative +#define Qtime_function_encoding Qbinary #define Qtime_zone_encoding Qtime_function_encoding #define Qmswindows_host_name_encoding Qmswindows_multibyte #define Qmswindows_service_name_encoding Qmswindows_multibyte -- “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-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

[COMMIT] Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist() 14 years, 3 months

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1283341892 -3600 # Node ID b6a398dbb40329f1f111c181692ab1be47c133cf # Parent 378a34562cbe6d85cec615c1ae215708ab45054b Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist() src/ChangeLog addition: 2010-09-01 Aidan Kehoe <kehoea(a)parhasard.net> * fns.c (list_merge, list_array_merge_into_list) (list_array_merge_into_array): Avoid algorithmic complexity surprises when checking for circularity in these functions. (Freduce): Fix some formatting, in passing. (mapcarX): Drop the SOME_OR_EVERY argument to this function; instead, take CALLER, a symbol reflecting the Lisp-visible function that called mapcarX(). Use CALLER with mapping_interaction_error() when sequences are modified illegally. Don't cons with #'some, #'every, not even a little. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into, Fsome, Fevery): Call mapcarX() with its new arguments. (Fmapcan): Don't unnecessarily complicate the nconc call. (maplist): Take CALLER, a symbol reflecting the Lisp-visible function that called maplist(), rather than having separate arguments to indicate mapl vs. mapcon. Avoid algorithmic complexity surprises when checking for circularity. In #'mapcon, check a given stretch of result for well-formedness once, which was not previously the case, despite what the comments said. (Fmaplist, Fmapl, Fmapcon): Call maplist() with its new arguments. diff -r 378a34562cbe -r b6a398dbb403 src/ChangeLog --- a/src/ChangeLog Mon Aug 30 15:23:42 2010 +0100 +++ b/src/ChangeLog Wed Sep 01 12:51:32 2010 +0100 ＠＠ -1,3 +1,31 ＠＠ +2010-09-01 Aidan Kehoe <kehoea(a)parhasard.net> + + * fns.c (list_merge, list_array_merge_into_list) + (list_array_merge_into_array): + Avoid algorithmic complexity surprises when checking for + circularity in these functions. + (Freduce): Fix some formatting, in passing. + + (mapcarX): Drop the SOME_OR_EVERY argument to this function; + instead, take CALLER, a symbol reflecting the Lisp-visible + function that called mapcarX(). Use CALLER with + mapping_interaction_error() when sequences are modified + illegally. Don't cons with #'some, #'every, not even a little. + (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) + (Fmap_into, Fsome, Fevery): Call mapcarX() with its new + arguments. + (Fmapcan): Don't unnecessarily complicate the nconc call. + + (maplist): Take CALLER, a symbol reflecting the Lisp-visible + function that called maplist(), rather than having separate + arguments to indicate mapl vs. mapcon. + Avoid algorithmic complexity surprises when checking for + circularity. In #'mapcon, check a given stretch of + result for well-formedness once, which was not previously the + case, despite what the comments said. + (Fmaplist, Fmapl, Fmapcon): + Call maplist() with its new arguments. + 2010-08-30 Aidan Kehoe <kehoea(a)parhasard.net> * floatfns.c (ceiling_one_mundane_arg, floor_one_mundane_arg) diff -r 378a34562cbe -r b6a398dbb403 src/fns.c --- a/src/fns.c Mon Aug 30 15:23:42 2010 +0100 +++ b/src/fns.c Wed Sep 01 12:51:32 2010 +0100 ＠＠ -56,7 +56,9 ＠＠ Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill; Lisp_Object Qidentity; -Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Qreduce, Q_from_end, Q_initial_value; +Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value; +Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into; +Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce; Lisp_Object Qbase64_conversion_error; ＠＠ -2063,13 +2065,16 ＠＠ Lisp_Object tail; Lisp_Object tem; Lisp_Object l1, l2; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Lisp_Object tortoises[2]; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; int looped = 0; l1 = org_l1; l2 = org_l2; tail = Qnil; value = Qnil; + tortoises[0] = org_l1; + tortoises[1] = org_l2; if (NULL == c_predicate) { ＠＠ -2081,7 +2086,8 ＠＠ When l1 and l2 are updated, we copy the new values back into the org_ vars. */ - GCPRO4 (org_l1, org_l2, predicate, value); + GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); + gcpro5.nvars = 2; while (1) { ＠＠ -2120,19 +2126,24 ＠＠ Fsetcdr (tail, tem); tail = tem; - if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - /* Just check the lists aren't circular:*/ - { - EXTERNAL_LIST_LOOP_1 (l1) - { - } - } - { - EXTERNAL_LIST_LOOP_1 (l2) - { - } - } + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoises[0] = XCDR (tortoises[0]); + tortoises[1] = XCDR (tortoises[1]); + } + + if (EQ (org_l1, tortoises[0])) + { + signal_circular_list_error (org_l1); + } + + if (EQ (org_l2, tortoises[1])) + { + signal_circular_list_error (org_l2); + } + } } } ＠＠ -2230,12 +2241,12 ＠＠ Lisp_Object predicate, Lisp_Object key_func, Boolint reverse_order) { - Lisp_Object tail = Qnil, value = Qnil; - struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object tail = Qnil, value = Qnil, tortoise = list; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; Elemcount array_index = 0; int looped = 0; - GCPRO3 (list, tail, value); + GCPRO4 (list, tail, value, tortoise); while (1) { ＠＠ -2297,13 +2308,18 ＠＠ ++array_index; } - if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - { - EXTERNAL_LIST_LOOP_1 (list) - { - } - } + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (list, tortoise)) + { + signal_circular_list_error (list); + } + } } } ＠＠ -2377,7 +2393,7 ＠＠ { if (array_len - array_index != output_len - output_index) { - invalid_state ("List length modified during merge", Qunbound); + mapping_interaction_error (Qmerge, list); } while (array_index < array_len) ＠＠ -4105,35 +4121,34 ＠＠ so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off mapcarX. - Otherwise, mapcarX signals a wrong-type-error if it encounters a - non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in + Otherwise, mapcarX signals an invalid state error (see + mapping_interaction_error(), above) if it encounters a non-cons, + non-array when traversing SEQUENCES. Common Lisp specifies in MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION destructively modifies SEQUENCES in a way that might affect the ongoing traversal operation. - If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple) - values given by FUNCTION the first time it is non-nil, and abandon the - iterations. LISP_VALS must be a cons, and the return value will be - stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil - in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it - alone. */ - -#define SOME_OR_EVERY_NEITHER 0 -#define SOME_OR_EVERY_SOME 1 -#define SOME_OR_EVERY_EVERY 2 + CALLER is a symbol describing the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qsome, return the (possibly multiple) values given by + FUNCTION the first time it is non-nil, and abandon the iterations. + LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address + of a Lisp object, and the return value will be stored at that address. + If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp + object, and Qnil will be stored at that address if FUNCTION gives nil; + otherwise it will be left alone. */ static void mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals, Lisp_Object function, int nsequences, Lisp_Object *sequences, - int some_or_every) + Lisp_Object caller) { Lisp_Object called, *args; struct gcpro gcpro1, gcpro2; int i, j; - enum lrecord_type lisp_vals_type; - - assert (LRECORDP (lisp_vals)); - lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + + assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1); args = alloca_array (Lisp_Object, nsequences + 1); args[0] = function; ＠＠ -4177,12 +4192,21 ＠＠ } else { + enum lrecord_type lisp_vals_type; Binbyte *sequence_types = alloca_array (Binbyte, nsequences); for (j = 0; j < nsequences; ++j) { sequence_types[j] = XRECORD_LHEADER (sequences[j])->type; } + if (!EQ (caller, Qsome) && !EQ (caller, Qevery)) + { + assert (LRECORDP (lisp_vals)); + lisp_vals_type + = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + assert (NILP (lisp_vals) || lisp_vals_type != lrecord_type_symbol); + } + for (i = 0; i < call_count; ++i) { for (j = 0; j < nsequences; ++j) ＠＠ -4193,13 +4217,12 ＠＠ { if (!CONSP (sequences[j])) { - /* This means FUNCTION has probably messed - around with a cons in one of the sequences, - since we checked the type - (CHECK_SEQUENCE()) and the length and + /* This means FUNCTION has messed around with a cons + in one of the sequences, since we checked the + type (CHECK_SEQUENCE()) and the length and structure (with Flength()) correctly in our callers. */ - dead_wrong_type_argument (Qconsp, sequences[j]); + mapping_interaction_error (caller, sequences[j]); } args[j + 1] = XCAR (sequences[j]); sequences[j] = XCDR (sequences[j]); ＠＠ -4232,91 +4255,82 ＠＠ vals[i] = IGNORE_MULTIPLE_VALUES (called); gcpro2.nvars += 1; } - else - { - switch (lisp_vals_type) - { - case lrecord_type_symbol: - break; - case lrecord_type_cons: - { - if (SOME_OR_EVERY_NEITHER == some_or_every) - { - called = IGNORE_MULTIPLE_VALUES (called); - if (!CONSP (lisp_vals)) - { - /* If FUNCTION has inserted a non-cons non-nil - cdr into the list before we've processed the - relevant part, error. */ - dead_wrong_type_argument (Qconsp, lisp_vals); - } - - XSETCAR (lisp_vals, called); - lisp_vals = XCDR (lisp_vals); - break; - } - - if (SOME_OR_EVERY_SOME == some_or_every) - { - if (!NILP (IGNORE_MULTIPLE_VALUES (called))) - { - XCAR (lisp_vals) = called; - UNGCPRO; - return; - } - break; - } - - if (SOME_OR_EVERY_EVERY == some_or_every) - { - called = IGNORE_MULTIPLE_VALUES (called); - if (NILP (called)) - { - XCAR (lisp_vals) = Qnil; - UNGCPRO; - return; - } - break; - } - - goto bad_some_or_every_flag; - } - case lrecord_type_vector: - { - called = IGNORE_MULTIPLE_VALUES (called); - i < XVECTOR_LENGTH (lisp_vals) ? - (XVECTOR_DATA (lisp_vals)[i] = called) : - /* Let #'aset error. */ - Faset (lisp_vals, make_int (i), called); - break; - } - case lrecord_type_string: - { - /* If this ever becomes a code hotspot, we can keep - around pointers into the data of the string, checking - each time that it hasn't been relocated. */ - called = IGNORE_MULTIPLE_VALUES (called); - Faset (lisp_vals, make_int (i), called); - break; - } - case lrecord_type_bit_vector: - { - called = IGNORE_MULTIPLE_VALUES (called); - (BITP (called) && - i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? - set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, - XINT (called)) : - (void) Faset (lisp_vals, make_int (i), called); - break; - } - bad_some_or_every_flag: - default: - { - ABORT(); - break; - } - } - } + else if (EQ (Qsome, caller)) + { + if (!NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = called; + UNGCPRO; + return; + } + } + else if (EQ (Qevery, caller)) + { + if (NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = Qnil; + UNGCPRO; + return; + } + } + else + { + called = IGNORE_MULTIPLE_VALUES (called); + switch (lisp_vals_type) + { + case lrecord_type_symbol: + /* This is #'mapc; the result of the funcall is + discarded. */ + break; + case lrecord_type_cons: + { + if (!CONSP (lisp_vals)) + { + /* If FUNCTION has inserted a non-cons non-nil + cdr into the list before we've processed the + relevant part, error. */ + mapping_interaction_error (caller, lisp_vals); + } + XSETCAR (lisp_vals, called); + lisp_vals = XCDR (lisp_vals); + break; + } + case lrecord_type_vector: + { + i < XVECTOR_LENGTH (lisp_vals) ? + (XVECTOR_DATA (lisp_vals)[i] = called) : + /* Let #'aset error. */ + Faset (lisp_vals, make_int (i), called); + break; + } + case lrecord_type_string: + { + /* If this ever becomes a code hotspot, we can keep + around pointers into the data of the string, checking + each time that it hasn't been relocated. */ + Faset (lisp_vals, make_int (i), called); + break; + } + case lrecord_type_bit_vector: + { + (BITP (called) && + i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? + set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, + XINT (called)) : + (void) Faset (lisp_vals, make_int (i), called); + break; + } + default: + { + ABORT(); + break; + } + } + } } } UNGCPRO; ＠＠ -4373,8 +4387,7 ＠＠ } else { - mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat); } for (i = len - 1; i >= 0; i--) ＠＠ -4412,8 +4425,7 ＠＠ } args0 = alloca_array (Lisp_Object, len); - mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX); return Flist ((int) len, args0); } ＠＠ -4449,10 +4461,8 ＠＠ /* Don't pass result as the lisp_object argument, we want mapcarX to protect a single list argument's elements from being garbage-collected. */ mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, - SOME_OR_EVERY_NEITHER); - UNGCPRO; - - return result; + Qmapvector); + RETURN_UNGCPRO (result); } DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /* ＠＠ -4470,40 +4480,21 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object function = args[0], nconcing; - Elemcount len = EMACS_INT_MAX; - Lisp_Object *args0; - struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - args0 = alloca_array (Lisp_Object, len + 1); - mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); - - if (len < 2) - { - return len ? args0[1] : Qnil; - } - - /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since - mapcarX is no longer doing this for us. */ - args0[0] = Fcons (Qnil, Qnil); - GCPRO1 (args0[0]); - gcpro1.nvars = len + 1; - - for (i = 0; i < len; ++i) - { - nconcing = bytecode_nconc2 (args0 + i); - args0[i + 1] = nconcing; - } - - RETURN_UNGCPRO (XCDR (nconcing)); + Lisp_Object function = args[0], *result; + Elemcount result_len = EMACS_INT_MAX; + int i; + + for (i = 1; i < nargs; ++i) + { + CHECK_SEQUENCE (args[i]); + result_len = min (result_len, XINT (Flength (args[i]))); + } + + result = alloca_array (Lisp_Object, result_len); + mapcarX (result_len, result, Qnil, function, nargs - 1, args + 1, Qmapcan); + + /* #'nconc GCPROs its args in case of signals and error. */ + return Fnconc (result_len, result); } DEFUN ("mapc", Fmapc, 2, MANY, 0, /* ＠＠ -4539,8 +4530,7 ＠＠ elements of the args array handed to it, and this may involve elements of sequence getting garbage collected. */ GCPRO1 (sequence); - mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); + mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc); RETURN_UNGCPRO (sequence); } ＠＠ -4580,8 +4570,7 ＠＠ args0 = alloca_array (Lisp_Object, len); } - mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap); if (EQ (type, Qnil)) { ＠＠ -4646,7 +4635,7 ＠＠ } mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + Qmap_into); return result_sequence; } ＠＠ -4663,23 +4652,20 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object result_box = Fcons (Qnil, Qnil); - struct gcpro gcpro1; - Elemcount len = EMACS_INT_MAX; - int i; - - GCPRO1 (result_box); - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, - SOME_OR_EVERY_SOME); - - RETURN_UNGCPRO (XCAR (result_box)); + Lisp_Object result = Qnil, + result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = EMACS_INT_MAX; + int i; + + for (i = 1; i < nargs; ++i) + { + CHECK_SEQUENCE (args[i]); + len = min (len, XINT (Flength (args[i]))); + } + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome); + + return result; } DEFUN ("every", Fevery, 2, MANY, 0, /* ＠＠ -4694,43 +4680,42 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object result_box = Fcons (Qt, Qnil); - struct gcpro gcpro1; - Elemcount len = EMACS_INT_MAX; - int i; - - GCPRO1 (result_box); - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, - SOME_OR_EVERY_EVERY); - - RETURN_UNGCPRO (XCAR (result_box)); + Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = EMACS_INT_MAX; + int i; + + for (i = 1; i < nargs; ++i) + { + CHECK_SEQUENCE (args[i]); + len = min (len, XINT (Flength (args[i]))); + } + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery); + + return result; } /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]), until that #'nthcdr expression gives nil for some element of LISTS. - If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return - values from FUNCTION; if NCONCP is non-zero, nconc them together. + CALLER is a symbol reflecting the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qmapl, return LISTS[0]. Otherwise, return a list of the + return values from FUNCTION; if caller is Qmapcan, nconc them together. In contrast to mapcarX, we don't require our callers to check LISTS for well-formedness, we signal wrong-type-argument if it's not a list, or circular-list if it's circular. */ static Lisp_Object -maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp, - int nconcp) -{ - Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled; - Lisp_Object nconcing[2], accum = result, *args; - struct gcpro gcpro1, gcpro2, gcpro3; +maplist (Lisp_Object function, int nlists, Lisp_Object *lists, + Lisp_Object caller) +{ + Lisp_Object nconcing[2], accum = Qnil, *args, *tortoises, funcalled; + Lisp_Object result = EQ (caller, Qmapl) ? lists[0] : Qnil; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; int i, j, continuing = (nlists > 0), called_count = 0; args = alloca_array (Lisp_Object, nlists + 1); ＠＠ -4740,18 +4725,23 ＠＠ args[i] = Qnil; } - if (nconcp) - { - nconcing[0] = result; + tortoises = alloca_array (Lisp_Object, nlists); + memcpy (tortoises, lists, nlists * sizeof (Lisp_Object)); + + if (EQ (caller, Qmapcon)) + { + nconcing[0] = Qnil; nconcing[1] = Qnil; - GCPRO3 (args[0], nconcing[0], result); + GCPRO4 (args[0], nconcing[0], tortoises[0], result); gcpro1.nvars = 1; gcpro2.nvars = 2; - } - else - { - GCPRO2 (args[0], result); + gcpro3.nvars = nlists; + } + else + { + GCPRO3 (args[0], tortoises[0], result); gcpro1.nvars = 1; + gcpro2.nvars = nlists; } while (continuing) ＠＠ -4770,45 +4760,64 ＠＠ } else { - dead_wrong_type_argument (Qlistp, lists[j]); + lists[j] = wrong_type_argument (Qlistp, lists[j]); } } if (!continuing) break; funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args)); - if (!maplp) - { - if (nconcp) - { - /* This order of calls means we check that each list is - well-formed once and once only. The last result does - not have to be a list. */ - nconcing[1] = funcalled; - nconcing[0] = bytecode_nconc2 (nconcing); - } - else - { - /* Add to the end, avoiding the need to call nreverse - once we're done: */ - XSETCDR (accum, Fcons (funcalled, Qnil)); - accum = XCDR (accum); - } - } - - if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - for (j = 0; j < nlists; ++j) - { - EXTERNAL_LIST_LOOP_1 (lists[j]) - { - /* Just check the lists aren't circular, using the - EXTERNAL_LIST_LOOP_1 macro. */ - } - } - } - - if (!maplp) - { - result = XCDR (result); + + if (EQ (caller, Qmapl)) + { + DO_NOTHING; + } + else if (EQ (caller, Qmapcon)) + { + nconcing[1] = funcalled; + accum = bytecode_nconc2 (nconcing); + if (NILP (result)) + { + result = accum; + } + /* Only check a given stretch of result for well-formedness + once: */ + nconcing[0] = funcalled; + } + else if (NILP (accum)) + { + accum = result = Fcons (funcalled, Qnil); + } + else + { + /* Add to the end, avoiding the need to call nreverse + once we're done: */ + XSETCDR (accum, Fcons (funcalled, Qnil)); + accum = XCDR (accum); + } + + if (++called_count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (called_count & 1) + { + for (j = 0; j < nlists; ++j) + { + tortoises[j] = XCDR (tortoises[j]); + if (EQ (lists[j], tortoises[j])) + { + signal_circular_list_error (lists[j]); + } + } + } + else + { + for (j = 0; j < nlists; ++j) + { + if (EQ (lists[j], tortoises[j])) + { + signal_circular_list_error (lists[j]); + } + } + } + } } RETURN_UNGCPRO (result); ＠＠ -4823,7 +4832,7 ＠＠ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 0, 0); + return maplist (args[0], nargs - 1, args + 1, Qmaplist); } DEFUN ("mapl", Fmapl, 2, MANY, 0, /* ＠＠ -4833,7 +4842,7 ＠＠ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 1, 0); + return maplist (args[0], nargs - 1, args + 1, Qmapl); } DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /* ＠＠ -4846,7 +4855,7 ＠＠ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 0, 1); + return maplist (args[0], nargs - 1, args + 1, Qmapcon); } /* Extra random functions */ ＠＠ -5149,7 +5158,8 ＠＠ Elemcount counting = 0, len = 0; struct gcpro gcpro1; - if (ending - starting && starting < ending && EMACS_INT_MAX == ending) + if (ending - starting && starting < ending + && EMACS_INT_MAX == ending) { ending = XINT (Flength (sequence)); } ＠＠ -5916,6 +5926,19 ＠＠ defsymbol (&QsortX, "sort*"); DEFSYMBOL (Qreduce); + DEFSYMBOL (Qmapconcat); + defsymbol (&QmapcarX, "mapcar*"); + DEFSYMBOL (Qmapvector); + DEFSYMBOL (Qmapcan); + DEFSYMBOL (Qmapc); + DEFSYMBOL (Qmap); + DEFSYMBOL (Qmap_into); + DEFSYMBOL (Qsome); + DEFSYMBOL (Qevery); + DEFSYMBOL (Qmaplist); + DEFSYMBOL (Qmapl); + DEFSYMBOL (Qmapcon); + DEFKEYWORD (Q_from_end); DEFKEYWORD (Q_initial_value); -- “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-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

commit: Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist() 14 years, 3 months

Aidan Kehoe

changeset: 5253:b6a398dbb403 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net> date: Wed Sep 01 12:51:32 2010 +0100 files: src/ChangeLog src/fns.c description: Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist() src/ChangeLog addition: 2010-09-01 Aidan Kehoe <kehoea(a)parhasard.net> * fns.c (list_merge, list_array_merge_into_list) (list_array_merge_into_array): Avoid algorithmic complexity surprises when checking for circularity in these functions. (Freduce): Fix some formatting, in passing. (mapcarX): Drop the SOME_OR_EVERY argument to this function; instead, take CALLER, a symbol reflecting the Lisp-visible function that called mapcarX(). Use CALLER with mapping_interaction_error() when sequences are modified illegally. Don't cons with #'some, #'every, not even a little. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into, Fsome, Fevery): Call mapcarX() with its new arguments. (Fmapcan): Don't unnecessarily complicate the nconc call. (maplist): Take CALLER, a symbol reflecting the Lisp-visible function that called maplist(), rather than having separate arguments to indicate mapl vs. mapcon. Avoid algorithmic complexity surprises when checking for circularity. In #'mapcon, check a given stretch of result for well-formedness once, which was not previously the case, despite what the comments said. (Fmaplist, Fmapl, Fmapcon): Call maplist() with its new arguments. diff -r 378a34562cbe -r b6a398dbb403 src/ChangeLog --- a/src/ChangeLog Mon Aug 30 15:23:42 2010 +0100 +++ b/src/ChangeLog Wed Sep 01 12:51:32 2010 +0100 ＠＠ -1,3 +1,31 ＠＠ +2010-09-01 Aidan Kehoe <kehoea(a)parhasard.net> + + * fns.c (list_merge, list_array_merge_into_list) + (list_array_merge_into_array): + Avoid algorithmic complexity surprises when checking for + circularity in these functions. + (Freduce): Fix some formatting, in passing. + + (mapcarX): Drop the SOME_OR_EVERY argument to this function; + instead, take CALLER, a symbol reflecting the Lisp-visible + function that called mapcarX(). Use CALLER with + mapping_interaction_error() when sequences are modified + illegally. Don't cons with #'some, #'every, not even a little. + (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) + (Fmap_into, Fsome, Fevery): Call mapcarX() with its new + arguments. + (Fmapcan): Don't unnecessarily complicate the nconc call. + + (maplist): Take CALLER, a symbol reflecting the Lisp-visible + function that called maplist(), rather than having separate + arguments to indicate mapl vs. mapcon. + Avoid algorithmic complexity surprises when checking for + circularity. In #'mapcon, check a given stretch of + result for well-formedness once, which was not previously the + case, despite what the comments said. + (Fmaplist, Fmapl, Fmapcon): + Call maplist() with its new arguments. + 2010-08-30 Aidan Kehoe <kehoea(a)parhasard.net> * floatfns.c (ceiling_one_mundane_arg, floor_one_mundane_arg) diff -r 378a34562cbe -r b6a398dbb403 src/fns.c --- a/src/fns.c Mon Aug 30 15:23:42 2010 +0100 +++ b/src/fns.c Wed Sep 01 12:51:32 2010 +0100 ＠＠ -56,7 +56,9 ＠＠ Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill; Lisp_Object Qidentity; -Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Qreduce, Q_from_end, Q_initial_value; +Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value; +Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into; +Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce; Lisp_Object Qbase64_conversion_error; ＠＠ -2063,13 +2065,16 ＠＠ Lisp_Object tail; Lisp_Object tem; Lisp_Object l1, l2; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Lisp_Object tortoises[2]; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; int looped = 0; l1 = org_l1; l2 = org_l2; tail = Qnil; value = Qnil; + tortoises[0] = org_l1; + tortoises[1] = org_l2; if (NULL == c_predicate) { ＠＠ -2081,7 +2086,8 ＠＠ When l1 and l2 are updated, we copy the new values back into the org_ vars. */ - GCPRO4 (org_l1, org_l2, predicate, value); + GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); + gcpro5.nvars = 2; while (1) { ＠＠ -2120,19 +2126,24 ＠＠ Fsetcdr (tail, tem); tail = tem; - if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - /* Just check the lists aren't circular:*/ - { - EXTERNAL_LIST_LOOP_1 (l1) - { - } - } - { - EXTERNAL_LIST_LOOP_1 (l2) - { - } - } + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoises[0] = XCDR (tortoises[0]); + tortoises[1] = XCDR (tortoises[1]); + } + + if (EQ (org_l1, tortoises[0])) + { + signal_circular_list_error (org_l1); + } + + if (EQ (org_l2, tortoises[1])) + { + signal_circular_list_error (org_l2); + } + } } } ＠＠ -2230,12 +2241,12 ＠＠ Lisp_Object predicate, Lisp_Object key_func, Boolint reverse_order) { - Lisp_Object tail = Qnil, value = Qnil; - struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object tail = Qnil, value = Qnil, tortoise = list; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; Elemcount array_index = 0; int looped = 0; - GCPRO3 (list, tail, value); + GCPRO4 (list, tail, value, tortoise); while (1) { ＠＠ -2297,13 +2308,18 ＠＠ ++array_index; } - if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - { - EXTERNAL_LIST_LOOP_1 (list) - { - } - } + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (list, tortoise)) + { + signal_circular_list_error (list); + } + } } } ＠＠ -2377,7 +2393,7 ＠＠ { if (array_len - array_index != output_len - output_index) { - invalid_state ("List length modified during merge", Qunbound); + mapping_interaction_error (Qmerge, list); } while (array_index < array_len) ＠＠ -4105,35 +4121,34 ＠＠ so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off mapcarX. - Otherwise, mapcarX signals a wrong-type-error if it encounters a - non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in + Otherwise, mapcarX signals an invalid state error (see + mapping_interaction_error(), above) if it encounters a non-cons, + non-array when traversing SEQUENCES. Common Lisp specifies in MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION destructively modifies SEQUENCES in a way that might affect the ongoing traversal operation. - If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple) - values given by FUNCTION the first time it is non-nil, and abandon the - iterations. LISP_VALS must be a cons, and the return value will be - stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil - in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it - alone. */ - -#define SOME_OR_EVERY_NEITHER 0 -#define SOME_OR_EVERY_SOME 1 -#define SOME_OR_EVERY_EVERY 2 + CALLER is a symbol describing the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qsome, return the (possibly multiple) values given by + FUNCTION the first time it is non-nil, and abandon the iterations. + LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address + of a Lisp object, and the return value will be stored at that address. + If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp + object, and Qnil will be stored at that address if FUNCTION gives nil; + otherwise it will be left alone. */ static void mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals, Lisp_Object function, int nsequences, Lisp_Object *sequences, - int some_or_every) + Lisp_Object caller) { Lisp_Object called, *args; struct gcpro gcpro1, gcpro2; int i, j; - enum lrecord_type lisp_vals_type; - - assert (LRECORDP (lisp_vals)); - lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + + assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1); args = alloca_array (Lisp_Object, nsequences + 1); args[0] = function; ＠＠ -4177,11 +4192,20 ＠＠ } else { + enum lrecord_type lisp_vals_type; Binbyte *sequence_types = alloca_array (Binbyte, nsequences); for (j = 0; j < nsequences; ++j) { sequence_types[j] = XRECORD_LHEADER (sequences[j])->type; } + + if (!EQ (caller, Qsome) && !EQ (caller, Qevery)) + { + assert (LRECORDP (lisp_vals)); + lisp_vals_type + = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + assert (NILP (lisp_vals) || lisp_vals_type != lrecord_type_symbol); + } for (i = 0; i < call_count; ++i) { ＠＠ -4193,13 +4217,12 ＠＠ { if (!CONSP (sequences[j])) { - /* This means FUNCTION has probably messed - around with a cons in one of the sequences, - since we checked the type - (CHECK_SEQUENCE()) and the length and + /* This means FUNCTION has messed around with a cons + in one of the sequences, since we checked the + type (CHECK_SEQUENCE()) and the length and structure (with Flength()) correctly in our callers. */ - dead_wrong_type_argument (Qconsp, sequences[j]); + mapping_interaction_error (caller, sequences[j]); } args[j + 1] = XCAR (sequences[j]); sequences[j] = XCDR (sequences[j]); ＠＠ -4232,91 +4255,82 ＠＠ vals[i] = IGNORE_MULTIPLE_VALUES (called); gcpro2.nvars += 1; } - else - { - switch (lisp_vals_type) - { - case lrecord_type_symbol: - break; - case lrecord_type_cons: - { - if (SOME_OR_EVERY_NEITHER == some_or_every) - { - called = IGNORE_MULTIPLE_VALUES (called); - if (!CONSP (lisp_vals)) - { - /* If FUNCTION has inserted a non-cons non-nil - cdr into the list before we've processed the - relevant part, error. */ - dead_wrong_type_argument (Qconsp, lisp_vals); - } - - XSETCAR (lisp_vals, called); - lisp_vals = XCDR (lisp_vals); - break; - } - - if (SOME_OR_EVERY_SOME == some_or_every) - { - if (!NILP (IGNORE_MULTIPLE_VALUES (called))) - { - XCAR (lisp_vals) = called; - UNGCPRO; - return; - } - break; - } - - if (SOME_OR_EVERY_EVERY == some_or_every) - { - called = IGNORE_MULTIPLE_VALUES (called); - if (NILP (called)) - { - XCAR (lisp_vals) = Qnil; - UNGCPRO; - return; - } - break; - } - - goto bad_some_or_every_flag; - } - case lrecord_type_vector: - { - called = IGNORE_MULTIPLE_VALUES (called); - i < XVECTOR_LENGTH (lisp_vals) ? - (XVECTOR_DATA (lisp_vals)[i] = called) : - /* Let #'aset error. */ - Faset (lisp_vals, make_int (i), called); - break; - } - case lrecord_type_string: - { - /* If this ever becomes a code hotspot, we can keep - around pointers into the data of the string, checking - each time that it hasn't been relocated. */ - called = IGNORE_MULTIPLE_VALUES (called); - Faset (lisp_vals, make_int (i), called); - break; - } - case lrecord_type_bit_vector: - { - called = IGNORE_MULTIPLE_VALUES (called); - (BITP (called) && - i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? - set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, - XINT (called)) : - (void) Faset (lisp_vals, make_int (i), called); - break; - } - bad_some_or_every_flag: - default: - { - ABORT(); - break; - } - } - } + else if (EQ (Qsome, caller)) + { + if (!NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = called; + UNGCPRO; + return; + } + } + else if (EQ (Qevery, caller)) + { + if (NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = Qnil; + UNGCPRO; + return; + } + } + else + { + called = IGNORE_MULTIPLE_VALUES (called); + switch (lisp_vals_type) + { + case lrecord_type_symbol: + /* This is #'mapc; the result of the funcall is + discarded. */ + break; + case lrecord_type_cons: + { + if (!CONSP (lisp_vals)) + { + /* If FUNCTION has inserted a non-cons non-nil + cdr into the list before we've processed the + relevant part, error. */ + mapping_interaction_error (caller, lisp_vals); + } + XSETCAR (lisp_vals, called); + lisp_vals = XCDR (lisp_vals); + break; + } + case lrecord_type_vector: + { + i < XVECTOR_LENGTH (lisp_vals) ? + (XVECTOR_DATA (lisp_vals)[i] = called) : + /* Let #'aset error. */ + Faset (lisp_vals, make_int (i), called); + break; + } + case lrecord_type_string: + { + /* If this ever becomes a code hotspot, we can keep + around pointers into the data of the string, checking + each time that it hasn't been relocated. */ + Faset (lisp_vals, make_int (i), called); + break; + } + case lrecord_type_bit_vector: + { + (BITP (called) && + i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? + set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, + XINT (called)) : + (void) Faset (lisp_vals, make_int (i), called); + break; + } + default: + { + ABORT(); + break; + } + } + } } } UNGCPRO; ＠＠ -4373,8 +4387,7 ＠＠ } else { - mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat); } for (i = len - 1; i >= 0; i--) ＠＠ -4412,8 +4425,7 ＠＠ } args0 = alloca_array (Lisp_Object, len); - mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX); return Flist ((int) len, args0); } ＠＠ -4449,10 +4461,8 ＠＠ /* Don't pass result as the lisp_object argument, we want mapcarX to protect a single list argument's elements from being garbage-collected. */ mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, - SOME_OR_EVERY_NEITHER); - UNGCPRO; - - return result; + Qmapvector); + RETURN_UNGCPRO (result); } DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /* ＠＠ -4470,40 +4480,21 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object function = args[0], nconcing; - Elemcount len = EMACS_INT_MAX; - Lisp_Object *args0; - struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - args0 = alloca_array (Lisp_Object, len + 1); - mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); - - if (len < 2) - { - return len ? args0[1] : Qnil; - } - - /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since - mapcarX is no longer doing this for us. */ - args0[0] = Fcons (Qnil, Qnil); - GCPRO1 (args0[0]); - gcpro1.nvars = len + 1; - - for (i = 0; i < len; ++i) - { - nconcing = bytecode_nconc2 (args0 + i); - args0[i + 1] = nconcing; - } - - RETURN_UNGCPRO (XCDR (nconcing)); + Lisp_Object function = args[0], *result; + Elemcount result_len = EMACS_INT_MAX; + int i; + + for (i = 1; i < nargs; ++i) + { + CHECK_SEQUENCE (args[i]); + result_len = min (result_len, XINT (Flength (args[i]))); + } + + result = alloca_array (Lisp_Object, result_len); + mapcarX (result_len, result, Qnil, function, nargs - 1, args + 1, Qmapcan); + + /* #'nconc GCPROs its args in case of signals and error. */ + return Fnconc (result_len, result); } DEFUN ("mapc", Fmapc, 2, MANY, 0, /* ＠＠ -4539,8 +4530,7 ＠＠ elements of the args array handed to it, and this may involve elements of sequence getting garbage collected. */ GCPRO1 (sequence); - mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); + mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc); RETURN_UNGCPRO (sequence); } ＠＠ -4580,8 +4570,7 ＠＠ args0 = alloca_array (Lisp_Object, len); } - mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap); if (EQ (type, Qnil)) { ＠＠ -4646,7 +4635,7 ＠＠ } mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + Qmap_into); return result_sequence; } ＠＠ -4663,23 +4652,20 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object result_box = Fcons (Qnil, Qnil); - struct gcpro gcpro1; - Elemcount len = EMACS_INT_MAX; - int i; - - GCPRO1 (result_box); - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, - SOME_OR_EVERY_SOME); - - RETURN_UNGCPRO (XCAR (result_box)); + Lisp_Object result = Qnil, + result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = EMACS_INT_MAX; + int i; + + for (i = 1; i < nargs; ++i) + { + CHECK_SEQUENCE (args[i]); + len = min (len, XINT (Flength (args[i]))); + } + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome); + + return result; } DEFUN ("every", Fevery, 2, MANY, 0, /* ＠＠ -4694,43 +4680,42 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object result_box = Fcons (Qt, Qnil); - struct gcpro gcpro1; - Elemcount len = EMACS_INT_MAX; - int i; - - GCPRO1 (result_box); - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, - SOME_OR_EVERY_EVERY); - - RETURN_UNGCPRO (XCAR (result_box)); + Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = EMACS_INT_MAX; + int i; + + for (i = 1; i < nargs; ++i) + { + CHECK_SEQUENCE (args[i]); + len = min (len, XINT (Flength (args[i]))); + } + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery); + + return result; } /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]), until that #'nthcdr expression gives nil for some element of LISTS. - If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return - values from FUNCTION; if NCONCP is non-zero, nconc them together. + CALLER is a symbol reflecting the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qmapl, return LISTS[0]. Otherwise, return a list of the + return values from FUNCTION; if caller is Qmapcan, nconc them together. In contrast to mapcarX, we don't require our callers to check LISTS for well-formedness, we signal wrong-type-argument if it's not a list, or circular-list if it's circular. */ static Lisp_Object -maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp, - int nconcp) -{ - Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled; - Lisp_Object nconcing[2], accum = result, *args; - struct gcpro gcpro1, gcpro2, gcpro3; +maplist (Lisp_Object function, int nlists, Lisp_Object *lists, + Lisp_Object caller) +{ + Lisp_Object nconcing[2], accum = Qnil, *args, *tortoises, funcalled; + Lisp_Object result = EQ (caller, Qmapl) ? lists[0] : Qnil; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; int i, j, continuing = (nlists > 0), called_count = 0; args = alloca_array (Lisp_Object, nlists + 1); ＠＠ -4740,18 +4725,23 ＠＠ args[i] = Qnil; } - if (nconcp) - { - nconcing[0] = result; + tortoises = alloca_array (Lisp_Object, nlists); + memcpy (tortoises, lists, nlists * sizeof (Lisp_Object)); + + if (EQ (caller, Qmapcon)) + { + nconcing[0] = Qnil; nconcing[1] = Qnil; - GCPRO3 (args[0], nconcing[0], result); + GCPRO4 (args[0], nconcing[0], tortoises[0], result); gcpro1.nvars = 1; gcpro2.nvars = 2; - } - else - { - GCPRO2 (args[0], result); + gcpro3.nvars = nlists; + } + else + { + GCPRO3 (args[0], tortoises[0], result); gcpro1.nvars = 1; + gcpro2.nvars = nlists; } while (continuing) ＠＠ -4770,45 +4760,64 ＠＠ } else { - dead_wrong_type_argument (Qlistp, lists[j]); + lists[j] = wrong_type_argument (Qlistp, lists[j]); } } if (!continuing) break; funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args)); - if (!maplp) - { - if (nconcp) - { - /* This order of calls means we check that each list is - well-formed once and once only. The last result does - not have to be a list. */ - nconcing[1] = funcalled; - nconcing[0] = bytecode_nconc2 (nconcing); - } - else - { - /* Add to the end, avoiding the need to call nreverse - once we're done: */ - XSETCDR (accum, Fcons (funcalled, Qnil)); - accum = XCDR (accum); - } - } - - if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - for (j = 0; j < nlists; ++j) - { - EXTERNAL_LIST_LOOP_1 (lists[j]) - { - /* Just check the lists aren't circular, using the - EXTERNAL_LIST_LOOP_1 macro. */ - } - } - } - - if (!maplp) - { - result = XCDR (result); + + if (EQ (caller, Qmapl)) + { + DO_NOTHING; + } + else if (EQ (caller, Qmapcon)) + { + nconcing[1] = funcalled; + accum = bytecode_nconc2 (nconcing); + if (NILP (result)) + { + result = accum; + } + /* Only check a given stretch of result for well-formedness + once: */ + nconcing[0] = funcalled; + } + else if (NILP (accum)) + { + accum = result = Fcons (funcalled, Qnil); + } + else + { + /* Add to the end, avoiding the need to call nreverse + once we're done: */ + XSETCDR (accum, Fcons (funcalled, Qnil)); + accum = XCDR (accum); + } + + if (++called_count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (called_count & 1) + { + for (j = 0; j < nlists; ++j) + { + tortoises[j] = XCDR (tortoises[j]); + if (EQ (lists[j], tortoises[j])) + { + signal_circular_list_error (lists[j]); + } + } + } + else + { + for (j = 0; j < nlists; ++j) + { + if (EQ (lists[j], tortoises[j])) + { + signal_circular_list_error (lists[j]); + } + } + } + } } RETURN_UNGCPRO (result); ＠＠ -4823,7 +4832,7 ＠＠ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 0, 0); + return maplist (args[0], nargs - 1, args + 1, Qmaplist); } DEFUN ("mapl", Fmapl, 2, MANY, 0, /* ＠＠ -4833,7 +4842,7 ＠＠ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 1, 0); + return maplist (args[0], nargs - 1, args + 1, Qmapl); } DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /* ＠＠ -4846,7 +4855,7 ＠＠ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 0, 1); + return maplist (args[0], nargs - 1, args + 1, Qmapcon); } /* Extra random functions */ ＠＠ -5149,7 +5158,8 ＠＠ Elemcount counting = 0, len = 0; struct gcpro gcpro1; - if (ending - starting && starting < ending && EMACS_INT_MAX == ending) + if (ending - starting && starting < ending + && EMACS_INT_MAX == ending) { ending = XINT (Flength (sequence)); } ＠＠ -5915,6 +5925,19 ＠＠ DEFSYMBOL (Qbit_vector); defsymbol (&QsortX, "sort*"); DEFSYMBOL (Qreduce); + + DEFSYMBOL (Qmapconcat); + defsymbol (&QmapcarX, "mapcar*"); + DEFSYMBOL (Qmapvector); + DEFSYMBOL (Qmapcan); + DEFSYMBOL (Qmapc); + DEFSYMBOL (Qmap); + DEFSYMBOL (Qmap_into); + DEFSYMBOL (Qsome); + DEFSYMBOL (Qevery); + DEFSYMBOL (Qmaplist); + DEFSYMBOL (Qmapl); + DEFSYMBOL (Qmapcon); DEFKEYWORD (Q_from_end); DEFKEYWORD (Q_initial_value); _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches

1 participants
0 comments

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

XEmacs-Patches September 2010