5:52 p.m.
changeset: 5522:544e6336d37c
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
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>
* 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>
+
+ * 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>
* 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