changeset: 5522:544e6336d37c tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Sun Jun 19 17:43:03 2011 +0100 files: lisp/ChangeLog lisp/cl-macs.el lisp/subr.el description: 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) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches