[COMMIT] Reimplement a few GNU functions in terms of CL functions, subr.el

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1308501783 -3600 # Node ID 544e6336d37cbafad876c7a838a072bf1af6dce4 # Parent 3310f36295a0cc633e512469005151f8b311aa48 Reimplement a few GNU functions in terms of CL functions, subr.el 2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-macs.el: * cl-macs.el (assoc-ignore-case, assoc-ignore-representation): * cl-macs.el (member-ignore-case): New compiler macros. * subr.el (assoc-ignore-case): * subr.el (assoc-ignore-representation): * subr.el (member-ignore-case): * subr.el (split-path): * subr.el (delete-dups): Reimplement a few GNU functions in terms of their CL counterparts, for the sake of circularity checking and some speed; add type checking (used in interpreted code and with low speed and safety checking) for the sake of revealing incompatibilities when developing. * subr.el (remove-hook): There's no need for flet here, an explicit lambda is enough. diff -r 3310f36295a0 -r 544e6336d37c lisp/ChangeLog --- a/lisp/ChangeLog Sun Jun 19 16:53:03 2011 +0100 +++ b/lisp/ChangeLog Sun Jun 19 17:43:03 2011 +0100 ＠＠ -1,3 +1,21 ＠＠ +2011-06-19 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * cl-macs.el: + * cl-macs.el (assoc-ignore-case, assoc-ignore-representation): + * cl-macs.el (member-ignore-case): New compiler macros. + * subr.el (assoc-ignore-case): + * subr.el (assoc-ignore-representation): + * subr.el (member-ignore-case): + * subr.el (split-path): + * subr.el (delete-dups): + Reimplement a few GNU functions in terms of their CL counterparts, + for the sake of circularity checking and some speed; add type + checking (used in interpreted code and with low speed and safety + checking) for the sake of revealing incompatibilities when + developing. + * subr.el (remove-hook): + There's no need for flet here, an explicit lambda is enough. + 2011-06-04 Aidan Kehoe <kehoea(a)parhasard.net&gt; * gutter-items.el (add-tab-to-gutter): diff -r 3310f36295a0 -r 544e6336d37c lisp/cl-macs.el --- a/lisp/cl-macs.el Sun Jun 19 16:53:03 2011 +0100 +++ b/lisp/cl-macs.el Sun Jun 19 17:43:03 2011 +0100 ＠＠ -3766,6 +3766,35 ＠＠ (the string ,string) :test #'eq) form)) +(define-compiler-macro assoc-ignore-case (&whole form &rest args) + (if (eql 2 (length args)) + `(assoc* (the string ,(pop args)) + (the (and list (satisfies + (lambda (list) + (not (find-if-not 'stringp list :key 'car))))) + ,(pop args)) +:test 'equalp) + form)) + +(define-compiler-macro assoc-ignore-representation (&whole form &rest args) + (if (eql 2 (length args)) + `(assoc* (the string ,(pop args)) + (the (and list (satisfies + (lambda (list) + (not (find-if-not 'stringp list :key 'car))))) + ,(pop args)) +:test 'equalp) + form)) + +(define-compiler-macro member-ignore-case (&whole form &rest args) + (if (eql 2 (length args)) + `(member* (the string ,(pop args)) + (the (and list (satisfies + (lambda (list) (every 'stringp list)))) + ,(pop args)) +:test 'equalp) + form)) + (define-compiler-macro stable-union (&whole form &rest cl-keys) (if (> (length form) 2) (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys) diff -r 3310f36295a0 -r 544e6336d37c lisp/subr.el --- a/lisp/subr.el Sun Jun 19 16:53:03 2011 +0100 +++ b/lisp/subr.el Sun Jun 19 17:43:03 2011 +0100 ＠＠ -111,10 +111,6 ＠＠ ;(defun butlast (x &optional n) ;(defun nbutlast (x &optional n) -;; In cl-seq.el. -;(defun remove (elt seq) -;(defun remq (elt list) - (defmacro defun-when-void (&rest args) "Define a function, just like `defun', unless it's already defined. Used for compatibility among different emacs variants." ＠＠ -185,30 +181,28 ＠＠ (defun assoc-ignore-case (key alist) "Like `assoc', but ignores differences in case and text representation. KEY must be a string. Upper-case and lower-case letters are treated as equal." - (let (element) - (while (and alist (not element)) - (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t)) - (setq element (car alist))) - (setq alist (cdr alist))) - element)) + (assoc* (the string key) + (the (and list (satisfies (lambda (list) + (not (find-if-not 'stringp list +:key 'car))))) alist) +:test 'equalp)) (defun assoc-ignore-representation (key alist) "Like `assoc', but ignores differences in text representation. KEY must be a string." - (let (element) - (while (and alist (not element)) - (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil)) - (setq element (car alist))) - (setq alist (cdr alist))) - element)) + (assoc* (the string key) + (the (and list (satisfies (lambda (list) + (not (find-if-not 'stringp list +:key 'car))))) alist) +:test 'equalp)) (defun member-ignore-case (elt list) "Like `member', but ignores differences in case and text representation. ELT must be a string. Upper-case and lower-case letters are treated as equal." - (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t)))) - (setq list (cdr list))) - list) - + (member* (the string elt) + (the (and list (satisfies (lambda (list) (every 'stringp list)))) + list) +:test 'equalp))  ;;;; Keymap support. ;; XEmacs: removed to keymap.el ＠＠ -351,23 +345,17 ＠＠ (setq local t))) (let ((hook-value (if local (symbol-value hook) (default-value hook)))) ;; Remove the function, for both the list and the non-list cases. - ;; XEmacs: add hook-test, for handling one-shot hooks. - (flet ((hook-test - (fn hel) - (or (equal fn hel) - (and (symbolp hel) - (equal fn - (get hel 'one-shot-hook-fun)))))) - (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) - (if (equal hook-value function) (setq hook-value nil)) - (setq hook-value (delete* function (copy-sequence hook-value) - :test 'hook-test))) - ;; If the function is on the global hook, we need to shadow it locally - ;;(when (and local (member* function (default-value hook) - ;; :test 'hook-test) - ;; (not (member* (cons 'not function) hook-value - ;; :test 'hook-test))) - ;; (push (cons 'not function) hook-value)) + ;; XEmacs: call #'remove-if, rather than delete, since we check for + ;; one-shot hooks too. + (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) + (if (equal hook-value function) (setq hook-value nil)) + (setq hook-value + (remove-if #'(lambda (elt) + (or (equal function elt) + (and (symbolp elt) + (equal function + (get elt 'one-shot-hook-fun))))) + hook-value)) ;; Set the actual variable (if local (set hook hook-value) (set-default hook hook-value))))) ＠＠ -493,8 +481,7 ＠＠ "Explode a search path into a list of strings. The path components are separated with the characters specified with `path-separator'." - (while (or (not (stringp path-separator)) - (/= (length path-separator) 1)) + (while (not (and (stringp path-separator) (eql (length path-separator) 1))) (setq path-separator (signal 'error (list "\ `path-separator' should be set to a single-character string" path-separator)))) ＠＠ -1722,11 +1709,7 ＠＠ Store the result in LIST and return it. LIST must be a proper list. Of several `equal' occurrences of an element in LIST, the first one is kept." - (let ((tail list)) - (while tail - (setcdr tail (delete (car tail) (cdr tail))) - (setq tail (cdr tail)))) - list) + (delete-duplicates (the list list) :test 'equal :from-end t)) ;; END SYNC WITH FSF 22.0.50.1 (CVS) -- ‘Iodine deficiency was endemic in parts of the UK until, through what has been described as “an unplanned and accidental public health triumph”, iodine was added to cattle feed to improve milk production in the 1930s.’ (EN Pearce, Lancet, June 2011) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches