Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 272:c5d627a313b1 r21-0b34

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b34
author cvs
date Mon, 13 Aug 2007 10:28:48 +0200
parents 41ff10fd062f
children 558f606b08ae
comparison
equal deleted inserted replaced
271:c7b7086b0a39 272:c5d627a313b1
73 73
74 74
75 ;;;; Keymap support. 75 ;;;; Keymap support.
76 ;; XEmacs: removed to keymap.el 76 ;; XEmacs: removed to keymap.el
77 77
78 ;;;; The global keymap tree. 78 ;;;; The global keymap tree.
79 79
80 ;;; global-map, esc-map, and ctl-x-map have their values set up in 80 ;;; global-map, esc-map, and ctl-x-map have their values set up in
81 ;;; keymap.c; we just give them docstrings here. 81 ;;; keymap.c; we just give them docstrings here.
82 82
83 ;;;; Event manipulation functions. 83 ;;;; Event manipulation functions.
84 84
85 ;; The call to `read' is to ensure that the value is computed at load time
86 ;; and not compiled into the .elc file. The value is negative on most
87 ;; machines, but not on all!
88 (defconst listify-key-sequence-1 (logior 128 (read "?\\M-\\^@")))
89
90 (defun listify-key-sequence (key)
91 "Convert a key sequence to a list of events."
92 (if (vectorp key)
93 (append key nil)
94 (mapcar (function (lambda (c)
95 (if (> c 127)
96 (logxor c listify-key-sequence-1)
97 c)))
98 (append key nil))))
99 ;; XEmacs: This stuff is done in C Code. 85 ;; XEmacs: This stuff is done in C Code.
100 86
101 ;;;; Obsolescent names for functions. 87 ;;;; Obsolescent names for functions.
102 ;; XEmacs: not used. 88 ;; XEmacs: not used.
103 89
170 (not (memq t (symbol-value hook))))) 156 (not (memq t (symbol-value hook)))))
171 ;; Alter the local value only. 157 ;; Alter the local value only.
172 (or (if (consp function) 158 (or (if (consp function)
173 (member function (symbol-value hook)) 159 (member function (symbol-value hook))
174 (memq function (symbol-value hook))) 160 (memq function (symbol-value hook)))
175 (set hook 161 (set hook
176 (if append 162 (if append
177 (append (symbol-value hook) (list function)) 163 (append (symbol-value hook) (list function))
178 (cons function (symbol-value hook))))) 164 (cons function (symbol-value hook)))))
179 ;; Alter the global value (which is also the only value, 165 ;; Alter the global value (which is also the only value,
180 ;; if the hook doesn't have a local value). 166 ;; if the hook doesn't have a local value).
181 (or (if (consp function) 167 (or (if (consp function)
182 (member function (default-value hook)) 168 (member function (default-value hook))
183 (memq function (default-value hook))) 169 (memq function (default-value hook)))
184 (set-default hook 170 (set-default hook
185 (if append 171 (if append
186 (append (default-value hook) (list function)) 172 (append (default-value hook) (list function))
187 (cons function (default-value hook))))))) 173 (cons function (default-value hook)))))))
188 174
189 (defun remove-hook (hook function &optional local) 175 (defun remove-hook (hook function &optional local)
258 244
259 ;;;; String functions. 245 ;;;; String functions.
260 246
261 ;; XEmacs 247 ;; XEmacs
262 (defun replace-in-string (str regexp newtext &optional literal) 248 (defun replace-in-string (str regexp newtext &optional literal)
263 "Replaces all matches in STR for REGEXP with NEWTEXT string, 249 "Replace all matches in STR for REGEXP with NEWTEXT string,
264 and returns the new string. 250 and returns the new string.
265 Optional LITERAL non-nil means do a literal replacement. 251 Optional LITERAL non-nil means do a literal replacement.
266 Otherwise treat \\ in NEWTEXT string as special: 252 Otherwise treat \\ in NEWTEXT string as special:
267 \\& means substitute original matched text, 253 \\& means substitute original matched text,
268 \\N means substitute match for \(...\) number N, 254 \\N means substitute match for \(...\) number N,
387 ,@body 373 ,@body
388 (buffer-string)) 374 (buffer-string))
389 (erase-buffer tempbuf))))) 375 (erase-buffer tempbuf)))))
390 376
391 (defun insert-face (string face) 377 (defun insert-face (string face)
392 "Insert STRING and highlight with FACE. Returns the extent created." 378 "Insert STRING and highlight with FACE. Return the extent created."
393 (let ((p (point)) ext) 379 (let ((p (point)) ext)
394 (insert string) 380 (insert string)
395 (setq ext (make-extent p (point))) 381 (setq ext (make-extent p (point)))
396 (set-extent-face ext face) 382 (set-extent-face ext face)
397 ext)) 383 ext))
590 (eq (car-safe object) 'lambda))) 576 (eq (car-safe object) 'lambda)))
591 577
592 578
593 579
594 (defun function-interactive (function) 580 (defun function-interactive (function)
595 "Returns the interactive specification of FUNCTION. 581 "Return the interactive specification of FUNCTION.
596 FUNCTION can be any funcallable object. 582 FUNCTION can be any funcallable object.
597 The specification will be returned as the list of the symbol `interactive' 583 The specification will be returned as the list of the symbol `interactive'
598 and the specs. 584 and the specs.
599 If FUNCTION is not interactive, nil will be returned." 585 If FUNCTION is not interactive, nil will be returned."
600 (setq function (indirect-function function)) 586 (setq function (indirect-function function))