Mercurial > hg > xemacs-beta
diff lisp/subr.el @ 5522:544e6336d37c
Reimplement a few GNU functions in terms of CL functions, subr.el
2011-06-19 Aidan Kehoe <kehoea@parhasard.net>
* 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.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 19 Jun 2011 17:43:03 +0100 |
parents | b0d87f92e60b |
children | b908c7265a2b |
line wrap: on
line diff
--- 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)