Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 924:1b114504fa80

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-07-16 08:18:35 by didierv] fix case problem in replace-in-string
author didierv
date Tue, 16 Jul 2002 08:18:36 +0000
parents 1e9272790fe0
children 3a01f3148bff
comparison
equal deleted inserted replaced
923:3b122a8e1d51 924:1b114504fa80
191 (not (default-boundp 'hook)) 191 (not (default-boundp 'hook))
192 (null (symbol-value hook)) ;value is nil, or 192 (null (symbol-value hook)) ;value is nil, or
193 (null function)) ;function is nil, then 193 (null function)) ;function is nil, then
194 nil ;Do nothing. 194 nil ;Do nothing.
195 (flet ((hook-remove 195 (flet ((hook-remove
196 (function hook-value) 196 (function hook-value)
197 (flet ((hook-test 197 (flet ((hook-test
198 (fn hel) 198 (fn hel)
199 (or (equal fn hel) 199 (or (equal fn hel)
200 (and (symbolp hel) 200 (and (symbolp hel)
201 (equal fn 201 (equal fn
202 (get hel 'one-shot-hook-fun)))))) 202 (get hel 'one-shot-hook-fun))))))
203 (if (and (consp hook-value) 203 (if (and (consp hook-value)
204 (not (functionp hook-value))) 204 (not (functionp hook-value)))
205 (if (member* function hook-value :test 'hook-test) 205 (if (member* function hook-value :test 'hook-test)
206 (setq hook-value 206 (setq hook-value
207 (delete* function (copy-sequence hook-value) 207 (delete* function (copy-sequence hook-value)
208 :test 'hook-test))) 208 :test 'hook-test)))
209 (if (equal hook-value function) 209 (if (equal hook-value function)
210 (setq hook-value nil))) 210 (setq hook-value nil)))
211 hook-value))) 211 hook-value)))
212 (if (or local 212 (if (or local
213 ;; Detect the case where make-local-variable was used on a hook 213 ;; Detect the case where make-local-variable was used on a hook
214 ;; and do what we used to do. 214 ;; and do what we used to do.
215 (and (local-variable-p hook (current-buffer)) 215 (and (local-variable-p hook (current-buffer))
216 (not (memq t (symbol-value hook))))) 216 (not (memq t (symbol-value hook)))))
217 (set hook (hook-remove function (symbol-value hook))) 217 (set hook (hook-remove function (symbol-value hook)))
218 (set-default hook (hook-remove function (default-value hook))))))) 218 (set-default hook (hook-remove function (default-value hook)))))))
219 219
220 ;; XEmacs addition 220 ;; XEmacs addition
221 ;; #### we need a coherent scheme for indicating compatibility info, 221 ;; #### we need a coherent scheme for indicating compatibility info,
399 `\\L' means begin downcasing all following characters. 399 `\\L' means begin downcasing all following characters.
400 `\\E' means terminate the effect of any `\\U' or `\\L'." 400 `\\E' means terminate the effect of any `\\U' or `\\L'."
401 (check-argument-type 'stringp str) 401 (check-argument-type 'stringp str)
402 (check-argument-type 'stringp newtext) 402 (check-argument-type 'stringp newtext)
403 (if (> (length str) 50) 403 (if (> (length str) 50)
404 (with-temp-buffer 404 (let ((cfs case-fold-search))
405 (insert str) 405 (with-temp-buffer
406 (goto-char 1) 406 (setq case-fold-search cfs)
407 (insert str)
408 (goto-char 1)
407 (while (re-search-forward regexp nil t) 409 (while (re-search-forward regexp nil t)
408 (replace-match newtext t literal)) 410 (replace-match newtext t literal))
409 (buffer-string)) 411 (buffer-string)))
410 (let ((start 0) newstr) 412 (let ((start 0) newstr)
411 (while (string-match regexp str start) 413 (while (string-match regexp str start)
412 (setq newstr (replace-match newtext t literal str) 414 (setq newstr (replace-match newtext t literal str)
413 start (+ (match-end 0) (- (length newstr) (length str))) 415 start (+ (match-end 0) (- (length newstr) (length str)))
414 str newstr)) 416 str newstr))
415 str))) 417 str)))
416 418
417 (defun split-string (string &optional pattern) 419 (defun split-string (string &optional pattern)
418 "Return a list of substrings of STRING which are separated by PATTERN. 420 "Return a list of substrings of STRING which are separated by PATTERN.
419 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." 421 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
420 (or pattern 422 (or pattern
462 (defmacro with-current-buffer (buffer &rest body) 464 (defmacro with-current-buffer (buffer &rest body)
463 "Temporarily make BUFFER the current buffer and execute the forms in BODY. 465 "Temporarily make BUFFER the current buffer and execute the forms in BODY.
464 The value returned is the value of the last form in BODY. 466 The value returned is the value of the last form in BODY.
465 See also `with-temp-buffer'." 467 See also `with-temp-buffer'."
466 `(save-current-buffer 468 `(save-current-buffer
467 (set-buffer ,buffer) 469 (set-buffer ,buffer)
468 ,@body)) 470 ,@body))
469 471
470 (defmacro with-temp-file (filename &rest forms) 472 (defmacro with-temp-file (filename &rest forms)
471 "Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME. 473 "Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME.
472 The value of the last form in FORMS is returned, like `progn'. 474 The value of the last form in FORMS is returned, like `progn'.
473 See also `with-temp-buffer'." 475 See also `with-temp-buffer'."
670 ;; ... take away the width of the ellipses from the 672 ;; ... take away the width of the ellipses from the
671 ;; destination. do all computations with new, shorter 673 ;; destination. do all computations with new, shorter
672 ;; width. the padding computed will get us exactly up to 674 ;; width. the padding computed will get us exactly up to
673 ;; the shorted width, which is right -- it just gets added 675 ;; the shorted width, which is right -- it just gets added
674 ;; to the right of the ellipses. 676 ;; to the right of the ellipses.
675 (setq end-column (- end-column (string-width ellipses))))) 677 (setq end-column (- end-column (string-width ellipses)))))
676 678
677 ;; find the index of END-COLUMN; bail out if end of string reached. 679 ;; find the index of END-COLUMN; bail out if end of string reached.
678 (condition-case nil 680 (condition-case nil
679 (while (< column end-column) 681 (while (< column end-column)
680 (setq last-column column 682 (setq last-column column
965 returned value is within range, and assigns the returned value 967 returned value is within range, and assigns the returned value
966 to ARGUMENT. Otherwise, this function signals a non-continuable 968 to ARGUMENT. Otherwise, this function signals a non-continuable
967 `args-out-of-range' error if the returned value is out of range." 969 `args-out-of-range' error if the returned value is out of range."
968 (if (symbolp argument) 970 (if (symbolp argument)
969 `(if (not (argument-in-range-p ,argument ,min ,max)) 971 `(if (not (argument-in-range-p ,argument ,min ,max))
970 (setq ,argument 972 (setq ,argument
971 (args-out-of-range ,argument ,min ,max))) 973 (args-out-of-range ,argument ,min ,max)))
972 (let ((newsym (gensym))) 974 (let ((newsym (gensym)))
973 `(let ((,newsym ,argument)) 975 `(let ((,newsym ,argument))
974 (if (not (argument-in-range-p ,newsym ,min ,max)) 976 (if (not (argument-in-range-p ,newsym ,min ,max))
975 (signal-error 'args-out-of-range ,newsym ,min ,max)))))) 977 (signal-error 'args-out-of-range ,newsym ,min ,max))))))
976 978
977 (defun signal-error (error-symbol data) 979 (defun signal-error (error-symbol data)
978 "Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA. 980 "Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA.
979 An error symbol is a symbol defined using `define-error'. 981 An error symbol is a symbol defined using `define-error'.
980 DATA should be a list. Its elements are printed as part of the error message. 982 DATA should be a list. Its elements are printed as part of the error message.
1156 ;;; (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded... 1158 ;;; (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded...
1157 1159
1158 (if (not (fboundp 'define-abbrev-table)) 1160 (if (not (fboundp 'define-abbrev-table))
1159 (progn 1161 (progn
1160 (setq abbrev-table-name-list '()) 1162 (setq abbrev-table-name-list '())
1161 (fset 'define-abbrev-table (function (lambda (name defs) 1163 (fset 'define-abbrev-table
1162 ;; These are fixed-up when abbrev.el loads. 1164 (function (lambda (name defs)
1163 (setq abbrev-table-name-list 1165 ;; These are fixed-up when abbrev.el loads.
1164 (cons (cons name defs) 1166 (setq abbrev-table-name-list
1165 abbrev-table-name-list))))))) 1167 (cons (cons name defs)
1168 abbrev-table-name-list)))))))
1166 1169
1167 ;;; `functionp' has been moved into C. 1170 ;;; `functionp' has been moved into C.
1168 1171
1169 ;;(defun functionp (object) 1172 ;;(defun functionp (object)
1170 ;; "Non-nil if OBJECT can be called as a function." 1173 ;; "Non-nil if OBJECT can be called as a function."
1268 (make-compatible 'eval-next-after-load "") 1271 (make-compatible 'eval-next-after-load "")
1269 1272
1270 ; alternate names (not obsolete) 1273 ; alternate names (not obsolete)
1271 (if (not (fboundp 'mod)) (define-function 'mod '%)) 1274 (if (not (fboundp 'mod)) (define-function 'mod '%))
1272 (define-function 'move-marker 'set-marker) 1275 (define-function 'move-marker 'set-marker)
1273 (define-function 'beep 'ding) ; preserve lingual purity 1276 (define-function 'beep 'ding) ; preserve lingual purity
1274 (define-function 'indent-to-column 'indent-to) 1277 (define-function 'indent-to-column 'indent-to)
1275 (define-function 'backward-delete-char 'delete-backward-char) 1278 (define-function 'backward-delete-char 'delete-backward-char)
1276 (define-function 'search-forward-regexp (symbol-function 're-search-forward)) 1279 (define-function 'search-forward-regexp (symbol-function 're-search-forward))
1277 (define-function 'search-backward-regexp (symbol-function 're-search-backward)) 1280 (define-function 'search-backward-regexp (symbol-function 're-search-backward))
1278 (define-function 'remove-directory 'delete-directory) 1281 (define-function 'remove-directory 'delete-directory)