Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 5522:544e6336d37c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
5521:3310f36295a0 5522:544e6336d37c
109 ;; Built-in. Our `last' is more powerful in that it handles circularity. 109 ;; Built-in. Our `last' is more powerful in that it handles circularity.
110 ;(defun last (x &optional n) 110 ;(defun last (x &optional n)
111 ;(defun butlast (x &optional n) 111 ;(defun butlast (x &optional n)
112 ;(defun nbutlast (x &optional n) 112 ;(defun nbutlast (x &optional n)
113 113
114 ;; In cl-seq.el.
115 ;(defun remove (elt seq)
116 ;(defun remq (elt list)
117
118 (defmacro defun-when-void (&rest args) 114 (defmacro defun-when-void (&rest args)
119 "Define a function, just like `defun', unless it's already defined. 115 "Define a function, just like `defun', unless it's already defined.
120 Used for compatibility among different emacs variants." 116 Used for compatibility among different emacs variants."
121 `(if (fboundp ',(car args)) 117 `(if (fboundp ',(car args))
122 nil 118 nil
183 value)) 179 value))
184 180
185 (defun assoc-ignore-case (key alist) 181 (defun assoc-ignore-case (key alist)
186 "Like `assoc', but ignores differences in case and text representation. 182 "Like `assoc', but ignores differences in case and text representation.
187 KEY must be a string. Upper-case and lower-case letters are treated as equal." 183 KEY must be a string. Upper-case and lower-case letters are treated as equal."
188 (let (element) 184 (assoc* (the string key)
189 (while (and alist (not element)) 185 (the (and list (satisfies (lambda (list)
190 (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t)) 186 (not (find-if-not 'stringp list
191 (setq element (car alist))) 187 :key 'car))))) alist)
192 (setq alist (cdr alist))) 188 :test 'equalp))
193 element))
194 189
195 (defun assoc-ignore-representation (key alist) 190 (defun assoc-ignore-representation (key alist)
196 "Like `assoc', but ignores differences in text representation. 191 "Like `assoc', but ignores differences in text representation.
197 KEY must be a string." 192 KEY must be a string."
198 (let (element) 193 (assoc* (the string key)
199 (while (and alist (not element)) 194 (the (and list (satisfies (lambda (list)
200 (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil)) 195 (not (find-if-not 'stringp list
201 (setq element (car alist))) 196 :key 'car))))) alist)
202 (setq alist (cdr alist))) 197 :test 'equalp))
203 element))
204 198
205 (defun member-ignore-case (elt list) 199 (defun member-ignore-case (elt list)
206 "Like `member', but ignores differences in case and text representation. 200 "Like `member', but ignores differences in case and text representation.
207 ELT must be a string. Upper-case and lower-case letters are treated as equal." 201 ELT must be a string. Upper-case and lower-case letters are treated as equal."
208 (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t)))) 202 (member* (the string elt)
209 (setq list (cdr list))) 203 (the (and list (satisfies (lambda (list) (every 'stringp list))))
210 list) 204 list)
211 205 :test 'equalp))
212 206
213 ;;;; Keymap support. 207 ;;;; Keymap support.
214 ;; XEmacs: removed to keymap.el 208 ;; XEmacs: removed to keymap.el
215 209
216 ;;;; The global keymap tree. 210 ;;;; The global keymap tree.
349 ;; and do what we used to do. 343 ;; and do what we used to do.
350 (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) 344 (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
351 (setq local t))) 345 (setq local t)))
352 (let ((hook-value (if local (symbol-value hook) (default-value hook)))) 346 (let ((hook-value (if local (symbol-value hook) (default-value hook))))
353 ;; Remove the function, for both the list and the non-list cases. 347 ;; Remove the function, for both the list and the non-list cases.
354 ;; XEmacs: add hook-test, for handling one-shot hooks. 348 ;; XEmacs: call #'remove-if, rather than delete, since we check for
355 (flet ((hook-test 349 ;; one-shot hooks too.
356 (fn hel) 350 (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
357 (or (equal fn hel) 351 (if (equal hook-value function) (setq hook-value nil))
358 (and (symbolp hel) 352 (setq hook-value
359 (equal fn 353 (remove-if #'(lambda (elt)
360 (get hel 'one-shot-hook-fun)))))) 354 (or (equal function elt)
361 (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) 355 (and (symbolp elt)
362 (if (equal hook-value function) (setq hook-value nil)) 356 (equal function
363 (setq hook-value (delete* function (copy-sequence hook-value) 357 (get elt 'one-shot-hook-fun)))))
364 :test 'hook-test))) 358 hook-value))
365 ;; If the function is on the global hook, we need to shadow it locally
366 ;;(when (and local (member* function (default-value hook)
367 ;; :test 'hook-test)
368 ;; (not (member* (cons 'not function) hook-value
369 ;; :test 'hook-test)))
370 ;; (push (cons 'not function) hook-value))
371 ;; Set the actual variable 359 ;; Set the actual variable
372 (if local (set hook hook-value) (set-default hook hook-value))))) 360 (if local (set hook hook-value) (set-default hook hook-value)))))
373 361
374 ;; XEmacs addition 362 ;; XEmacs addition
375 ;; #### we need a coherent scheme for indicating compatibility info, 363 ;; #### we need a coherent scheme for indicating compatibility info,
491 479
492 (defun split-path (path) 480 (defun split-path (path)
493 "Explode a search path into a list of strings. 481 "Explode a search path into a list of strings.
494 The path components are separated with the characters specified 482 The path components are separated with the characters specified
495 with `path-separator'." 483 with `path-separator'."
496 (while (or (not (stringp path-separator)) 484 (while (not (and (stringp path-separator) (eql (length path-separator) 1)))
497 (/= (length path-separator) 1))
498 (setq path-separator (signal 'error (list "\ 485 (setq path-separator (signal 'error (list "\
499 `path-separator' should be set to a single-character string" 486 `path-separator' should be set to a single-character string"
500 path-separator)))) 487 path-separator))))
501 (split-string-by-char path (aref path-separator 0))) 488 (split-string-by-char path (aref path-separator 0)))
502 489
1720 (defun delete-dups (list) 1707 (defun delete-dups (list)
1721 "Destructively remove `equal' duplicates from LIST. 1708 "Destructively remove `equal' duplicates from LIST.
1722 Store the result in LIST and return it. LIST must be a proper list. 1709 Store the result in LIST and return it. LIST must be a proper list.
1723 Of several `equal' occurrences of an element in LIST, the first 1710 Of several `equal' occurrences of an element in LIST, the first
1724 one is kept." 1711 one is kept."
1725 (let ((tail list)) 1712 (delete-duplicates (the list list) :test 'equal :from-end t))
1726 (while tail
1727 (setcdr tail (delete (car tail) (cdr tail)))
1728 (setq tail (cdr tail))))
1729 list)
1730 1713
1731 ;; END SYNC WITH FSF 22.0.50.1 (CVS) 1714 ;; END SYNC WITH FSF 22.0.50.1 (CVS)
1732 1715
1733 ;; (defun shell-quote-argument (argument) in process.el. 1716 ;; (defun shell-quote-argument (argument) in process.el.
1734 1717