| 1 | ;;; subr.el --- basic lisp subroutines for Emacs |
| 2 | |
| 3 | ;;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; This file is part of GNU Emacs. |
| 6 | |
| 7 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 8 | ;; it under the terms of the GNU General Public License as published by |
| 9 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 10 | ;; any later version. |
| 11 | |
| 12 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 15 | ;; GNU General Public License for more details. |
| 16 | |
| 17 | ;; You should have received a copy of the GNU General Public License |
| 18 | ;; along with GNU Emacs; see the file COPYING. If not, write to |
| 19 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
| 20 | |
| 21 | ;;; Code: |
| 22 | |
| 23 | \f |
| 24 | ;;;; Lisp language features. |
| 25 | |
| 26 | (defmacro lambda (&rest cdr) |
| 27 | "Return a lambda expression. |
| 28 | A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is |
| 29 | self-quoting; the result of evaluating the lambda expression is the |
| 30 | expression itself. The lambda expression may then be treated as a |
| 31 | function, i. e. stored as the function value of a symbol, passed to |
| 32 | funcall or mapcar, etcetera. |
| 33 | ARGS should take the same form as an argument list for a `defun'. |
| 34 | DOCSTRING should be a string, as described for `defun'. It may be omitted. |
| 35 | INTERACTIVE should be a call to the function `interactive', which see. |
| 36 | It may also be omitted. |
| 37 | BODY should be a list of lisp expressions." |
| 38 | ;; Note that this definition should not use backquotes; subr.el should not |
| 39 | ;; depend on backquote.el. |
| 40 | (list 'function (cons 'lambda cdr))) |
| 41 | |
| 42 | ;;(defmacro defun-inline (name args &rest body) |
| 43 | ;; "Create an \"inline defun\" (actually a macro). |
| 44 | ;;Use just like `defun'." |
| 45 | ;; (nconc (list 'defmacro name '(&rest args)) |
| 46 | ;; (if (stringp (car body)) |
| 47 | ;; (prog1 (list (car body)) |
| 48 | ;; (setq body (or (cdr body) body)))) |
| 49 | ;; (list (list 'cons (list 'quote |
| 50 | ;; (cons 'lambda (cons args body))) |
| 51 | ;; 'args)))) |
| 52 | |
| 53 | \f |
| 54 | ;;;; Window tree functions. |
| 55 | |
| 56 | (defun one-window-p (&optional nomini all-frames) |
| 57 | "Returns non-nil if there is only one window. |
| 58 | Optional arg NOMINI non-nil means don't count the minibuffer |
| 59 | even if it is active. |
| 60 | |
| 61 | The optional arg ALL-FRAMES t means count windows on all frames. |
| 62 | If it is `visible', count windows on all visible frames. |
| 63 | ALL-FRAMES nil or omitted means count only the selected frame, |
| 64 | plus the minibuffer it uses (which may be on another frame). |
| 65 | If ALL-FRAMES is neither nil nor t, count only the selected frame." |
| 66 | (let ((base-window (selected-window))) |
| 67 | (if (and nomini (eq base-window (minibuffer-window))) |
| 68 | (setq base-window (next-window base-window))) |
| 69 | (eq base-window |
| 70 | (next-window base-window (if nomini 'arg) all-frames)))) |
| 71 | |
| 72 | (defun walk-windows (proc &optional minibuf all-frames) |
| 73 | "Cycle through all visible windows, calling PROC for each one. |
| 74 | PROC is called with a window as argument. |
| 75 | Optional second arg MINIBUF t means count the minibuffer window |
| 76 | even if not active. If MINIBUF is neither t nor nil it means |
| 77 | not to count the minibuffer even if it is active. |
| 78 | |
| 79 | Optional third arg ALL-FRAMES, if t, means include all frames. |
| 80 | ALL-FRAMES nil or omitted means cycle within the selected frame, |
| 81 | but include the minibuffer window (if MINIBUF says so) that that |
| 82 | frame uses, even if it is on another frame. |
| 83 | If ALL-FRAMES is neither nil nor t, stick strictly to the selected frame." |
| 84 | ;; If we start from the minibuffer window, don't fail to come back to it. |
| 85 | (if (window-minibuffer-p (selected-window)) |
| 86 | (setq minibuf t)) |
| 87 | (let* ((walk-windows-start (selected-window)) |
| 88 | (walk-windows-current walk-windows-start)) |
| 89 | (while (progn |
| 90 | (setq walk-windows-current |
| 91 | (next-window walk-windows-current minibuf all-frames)) |
| 92 | (funcall proc walk-windows-current) |
| 93 | (not (eq walk-windows-current walk-windows-start)))))) |
| 94 | |
| 95 | (defun minibuffer-window-active-p (window) |
| 96 | "Return t if WINDOW (a minibuffer window) is now active." |
| 97 | ;; nil nil means include WINDOW's frame |
| 98 | ;; and other frames using WINDOW as minibuffer, |
| 99 | ;; and include minibuffer if active. |
| 100 | (let ((prev (previous-window window nil nil))) |
| 101 | ;; If PREV equals WINDOW, WINDOW must be on a minibuffer-only frame |
| 102 | ;; and it's not currently being used. So return nil. |
| 103 | (and (not (eq window prev)) |
| 104 | (let ((should-be-same (next-window prev nil nil))) |
| 105 | ;; If next-window doesn't reverse previous-window, |
| 106 | ;; WINDOW must be outside the cycle specified by nil nil. |
| 107 | (eq should-be-same window))))) |
| 108 | \f |
| 109 | ;;;; Keymap support. |
| 110 | |
| 111 | (defun undefined () |
| 112 | (interactive) |
| 113 | (ding)) |
| 114 | |
| 115 | ;Prevent the \{...} documentation construct |
| 116 | ;from mentioning keys that run this command. |
| 117 | (put 'undefined 'suppress-keymap t) |
| 118 | |
| 119 | (defun suppress-keymap (map &optional nodigits) |
| 120 | "Make MAP override all normally self-inserting keys to be undefined. |
| 121 | Normally, as an exception, digits and minus-sign are set to make prefix args, |
| 122 | but optional second arg NODIGITS non-nil treats them like other chars." |
| 123 | (substitute-key-definition 'self-insert-command 'undefined map global-map) |
| 124 | (or nodigits |
| 125 | (let (loop) |
| 126 | (define-key map "-" 'negative-argument) |
| 127 | ;; Make plain numbers do numeric args. |
| 128 | (setq loop ?0) |
| 129 | (while (<= loop ?9) |
| 130 | (define-key map (char-to-string loop) 'digit-argument) |
| 131 | (setq loop (1+ loop)))))) |
| 132 | |
| 133 | ;Moved to keymap.c |
| 134 | ;(defun copy-keymap (keymap) |
| 135 | ; "Return a copy of KEYMAP" |
| 136 | ; (while (not (keymapp keymap)) |
| 137 | ; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap)))) |
| 138 | ; (if (vectorp keymap) |
| 139 | ; (copy-sequence keymap) |
| 140 | ; (copy-alist keymap))) |
| 141 | |
| 142 | (defvar key-substitution-in-progress nil |
| 143 | "Used internally by substitute-key-definition.") |
| 144 | |
| 145 | (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) |
| 146 | "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. |
| 147 | In other words, OLDDEF is replaced with NEWDEF where ever it appears. |
| 148 | If optional fourth argument OLDMAP is specified, we redefine |
| 149 | in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP." |
| 150 | (or prefix (setq prefix "")) |
| 151 | (let* ((scan (or oldmap keymap)) |
| 152 | (vec1 (vector nil)) |
| 153 | (prefix1 (vconcat prefix vec1)) |
| 154 | (key-substitution-in-progress |
| 155 | (cons scan key-substitution-in-progress))) |
| 156 | ;; Scan OLDMAP, finding each char or event-symbol that |
| 157 | ;; has any definition, and act on it with hack-key. |
| 158 | (while (consp scan) |
| 159 | (if (consp (car scan)) |
| 160 | (let ((char (car (car scan))) |
| 161 | (defn (cdr (car scan)))) |
| 162 | ;; The inside of this let duplicates exactly |
| 163 | ;; the inside of the following let that handles array elements. |
| 164 | (aset vec1 0 char) |
| 165 | (aset prefix1 (length prefix) char) |
| 166 | (let (inner-def skipped) |
| 167 | ;; Skip past menu-prompt. |
| 168 | (while (stringp (car-safe defn)) |
| 169 | (setq skipped (cons (car defn) skipped)) |
| 170 | (setq defn (cdr defn))) |
| 171 | (setq inner-def defn) |
| 172 | (while (and (symbolp inner-def) |
| 173 | (fboundp inner-def)) |
| 174 | (setq inner-def (symbol-function inner-def))) |
| 175 | (if (eq defn olddef) |
| 176 | (define-key keymap prefix1 (nconc (nreverse skipped) newdef)) |
| 177 | (if (and (keymapp defn) |
| 178 | (not (memq inner-def |
| 179 | key-substitution-in-progress))) |
| 180 | (substitute-key-definition olddef newdef keymap |
| 181 | inner-def |
| 182 | prefix1))))) |
| 183 | (if (arrayp (car scan)) |
| 184 | (let* ((array (car scan)) |
| 185 | (len (length array)) |
| 186 | (i 0)) |
| 187 | (while (< i len) |
| 188 | (let ((char i) (defn (aref array i))) |
| 189 | ;; The inside of this let duplicates exactly |
| 190 | ;; the inside of the previous let. |
| 191 | (aset vec1 0 char) |
| 192 | (aset prefix1 (length prefix) char) |
| 193 | (let (inner-def skipped) |
| 194 | ;; Skip past menu-prompt. |
| 195 | (while (stringp (car-safe defn)) |
| 196 | (setq skipped (cons (car defn) skipped)) |
| 197 | (setq defn (cdr defn))) |
| 198 | (setq inner-def defn) |
| 199 | (while (and (symbolp inner-def) |
| 200 | (fboundp inner-def)) |
| 201 | (setq inner-def (symbol-function inner-def))) |
| 202 | (if (eq defn olddef) |
| 203 | (define-key keymap prefix1 |
| 204 | (nconc (nreverse skipped) newdef)) |
| 205 | (if (and (keymapp defn) |
| 206 | (not (memq inner-def |
| 207 | key-substitution-in-progress))) |
| 208 | (substitute-key-definition olddef newdef keymap |
| 209 | inner-def |
| 210 | prefix1))))) |
| 211 | (setq i (1+ i)))))) |
| 212 | (setq scan (cdr scan))))) |
| 213 | |
| 214 | (defun define-key-after (keymap key definition after) |
| 215 | "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. |
| 216 | This is like `define-key' except that the binding for KEY is placed |
| 217 | just after the binding for the event AFTER, instead of at the beginning |
| 218 | of the map. |
| 219 | The order matters when the keymap is used as a menu. |
| 220 | KEY must contain just one event type--that is to say, it must be |
| 221 | a string or vector of length 1." |
| 222 | (or (keymapp keymap) |
| 223 | (signal 'wrong-type-argument (list 'keymapp keymap))) |
| 224 | (if (> (length key) 1) |
| 225 | (error "multi-event key specified in `define-key-after'")) |
| 226 | (let ((tail keymap) done inserted |
| 227 | (first (aref key 0))) |
| 228 | (while (and (not done) tail) |
| 229 | ;; Delete any earlier bindings for the same key. |
| 230 | (if (eq (car-safe (car (cdr tail))) first) |
| 231 | (setcdr tail (cdr (cdr tail)))) |
| 232 | ;; When we reach AFTER's binding, insert the new binding after. |
| 233 | ;; If we reach an inherited keymap, insert just before that. |
| 234 | ;; If we reach the end of this keymap, insert at the end. |
| 235 | (if (or (eq (car-safe (car tail)) after) |
| 236 | (eq (car (cdr tail)) 'keymap) |
| 237 | (null (cdr tail))) |
| 238 | (progn |
| 239 | ;; Stop the scan only if we find a parent keymap. |
| 240 | ;; Keep going past the inserted element |
| 241 | ;; so we can delete any duplications that come later. |
| 242 | (if (eq (car (cdr tail)) 'keymap) |
| 243 | (setq done t)) |
| 244 | ;; Don't insert more than once. |
| 245 | (or inserted |
| 246 | (setcdr tail (cons (cons (aref key 0) definition) (cdr tail)))) |
| 247 | (setq inserted t))) |
| 248 | (setq tail (cdr tail))))) |
| 249 | |
| 250 | (defun keyboard-translate (from to) |
| 251 | "Translate character FROM to TO at a low level. |
| 252 | This function creates a `keyboard-translate-table' if necessary |
| 253 | and then modifies one entry in it." |
| 254 | (or (arrayp keyboard-translate-table) |
| 255 | (setq keyboard-translate-table "")) |
| 256 | (if (or (> from (length keyboard-translate-table)) |
| 257 | (> to (length keyboard-translate-table))) |
| 258 | (progn |
| 259 | (let* ((i (length keyboard-translate-table)) |
| 260 | (table (concat keyboard-translate-table |
| 261 | (make-string (- 256 i) 0)))) |
| 262 | (while (< i 256) |
| 263 | (aset table i i) |
| 264 | (setq i (1+ i))) |
| 265 | (setq keyboard-translate-table table)))) |
| 266 | (aset keyboard-translate-table from to)) |
| 267 | |
| 268 | \f |
| 269 | ;;;; The global keymap tree. |
| 270 | |
| 271 | ;;; global-map, esc-map, and ctl-x-map have their values set up in |
| 272 | ;;; keymap.c; we just give them docstrings here. |
| 273 | |
| 274 | (defvar global-map nil |
| 275 | "Default global keymap mapping Emacs keyboard input into commands. |
| 276 | The value is a keymap which is usually (but not necessarily) Emacs's |
| 277 | global map.") |
| 278 | |
| 279 | (defvar esc-map nil |
| 280 | "Default keymap for ESC (meta) commands. |
| 281 | The normal global definition of the character ESC indirects to this keymap.") |
| 282 | |
| 283 | (defvar ctl-x-map nil |
| 284 | "Default keymap for C-x commands. |
| 285 | The normal global definition of the character C-x indirects to this keymap.") |
| 286 | |
| 287 | (defvar ctl-x-4-map (make-sparse-keymap) |
| 288 | "Keymap for subcommands of C-x 4") |
| 289 | (defalias 'ctl-x-4-prefix ctl-x-4-map) |
| 290 | (define-key ctl-x-map "4" 'ctl-x-4-prefix) |
| 291 | |
| 292 | (defvar ctl-x-5-map (make-sparse-keymap) |
| 293 | "Keymap for frame commands.") |
| 294 | (defalias 'ctl-x-5-prefix ctl-x-5-map) |
| 295 | (define-key ctl-x-map "5" 'ctl-x-5-prefix) |
| 296 | |
| 297 | \f |
| 298 | ;;;; Event manipulation functions. |
| 299 | |
| 300 | ;; This code exists specifically to make sure that the |
| 301 | ;; resulting number does not appear in the .elc file. |
| 302 | ;; The number is negative on most machines, but not on all! |
| 303 | (defconst listify-key-sequence-1 |
| 304 | (lsh 1 7)) |
| 305 | (setq listify-key-sequence-1 (logior (lsh 1 23) listify-key-sequence-1)) |
| 306 | |
| 307 | (defun listify-key-sequence (key) |
| 308 | "Convert a key sequence to a list of events." |
| 309 | (if (vectorp key) |
| 310 | (append key nil) |
| 311 | (mapcar (function (lambda (c) |
| 312 | (if (> c 127) |
| 313 | (logxor c listify-key-sequence-1) |
| 314 | c))) |
| 315 | (append key nil)))) |
| 316 | |
| 317 | (defsubst eventp (obj) |
| 318 | "True if the argument is an event object." |
| 319 | (or (integerp obj) |
| 320 | (and (symbolp obj) |
| 321 | (get obj 'event-symbol-elements)) |
| 322 | (and (consp obj) |
| 323 | (symbolp (car obj)) |
| 324 | (get (car obj) 'event-symbol-elements)))) |
| 325 | |
| 326 | (defun event-modifiers (event) |
| 327 | "Returns a list of symbols representing the modifier keys in event EVENT. |
| 328 | The elements of the list may include `meta', `control', |
| 329 | `shift', `hyper', `super', `alt', `click', `double', `triple', `drag', |
| 330 | and `down'." |
| 331 | (let ((type event)) |
| 332 | (if (listp type) |
| 333 | (setq type (car type))) |
| 334 | (if (symbolp type) |
| 335 | (cdr (get type 'event-symbol-elements)) |
| 336 | (let ((list nil)) |
| 337 | (or (zerop (logand type (lsh 1 23))) |
| 338 | (setq list (cons 'meta list))) |
| 339 | (or (and (zerop (logand type (lsh 1 22))) |
| 340 | (>= (logand type 127) 32)) |
| 341 | (setq list (cons 'control list))) |
| 342 | (or (and (zerop (logand type (lsh 1 21))) |
| 343 | (= (logand type 255) (downcase (logand type 255)))) |
| 344 | (setq list (cons 'shift list))) |
| 345 | (or (zerop (logand type (lsh 1 20))) |
| 346 | (setq list (cons 'hyper list))) |
| 347 | (or (zerop (logand type (lsh 1 19))) |
| 348 | (setq list (cons 'super list))) |
| 349 | (or (zerop (logand type (lsh 1 18))) |
| 350 | (setq list (cons 'alt list))) |
| 351 | list)))) |
| 352 | |
| 353 | (defun event-basic-type (event) |
| 354 | "Returns the basic type of the given event (all modifiers removed). |
| 355 | The value is an ASCII printing character (not upper case) or a symbol." |
| 356 | (if (consp event) |
| 357 | (setq event (car event))) |
| 358 | (if (symbolp event) |
| 359 | (car (get event 'event-symbol-elements)) |
| 360 | (let ((base (logand event (1- (lsh 1 18))))) |
| 361 | (downcase (if (< base 32) (logior base 64) base))))) |
| 362 | |
| 363 | (defsubst mouse-movement-p (object) |
| 364 | "Return non-nil if OBJECT is a mouse movement event." |
| 365 | (and (consp object) |
| 366 | (eq (car object) 'mouse-movement))) |
| 367 | |
| 368 | (defsubst event-start (event) |
| 369 | "Return the starting position of EVENT. |
| 370 | If EVENT is a mouse press or a mouse click, this returns the location |
| 371 | of the event. |
| 372 | If EVENT is a drag, this returns the drag's starting position. |
| 373 | The return value is of the form |
| 374 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 375 | The `posn-' functions access elements of such lists." |
| 376 | (nth 1 event)) |
| 377 | |
| 378 | (defsubst event-end (event) |
| 379 | "Return the ending location of EVENT. EVENT should be a click or drag event. |
| 380 | If EVENT is a click event, this function is the same as `event-start'. |
| 381 | The return value is of the form |
| 382 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 383 | The `posn-' functions access elements of such lists." |
| 384 | (nth (if (consp (nth 2 event)) 2 1) event)) |
| 385 | |
| 386 | (defsubst event-click-count (event) |
| 387 | "Return the multi-click count of EVENT, a click or drag event. |
| 388 | The return value is a positive integer." |
| 389 | (if (integerp (nth 2 event)) (nth 2 event) 1)) |
| 390 | |
| 391 | (defsubst posn-window (position) |
| 392 | "Return the window in POSITION. |
| 393 | POSITION should be a list of the form |
| 394 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 395 | as returned by the `event-start' and `event-end' functions." |
| 396 | (nth 0 position)) |
| 397 | |
| 398 | (defsubst posn-point (position) |
| 399 | "Return the buffer location in POSITION. |
| 400 | POSITION should be a list of the form |
| 401 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 402 | as returned by the `event-start' and `event-end' functions." |
| 403 | (if (consp (nth 1 position)) |
| 404 | (car (nth 1 position)) |
| 405 | (nth 1 position))) |
| 406 | |
| 407 | (defsubst posn-x-y (position) |
| 408 | "Return the x and y coordinates in POSITION. |
| 409 | POSITION should be a list of the form |
| 410 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 411 | as returned by the `event-start' and `event-end' functions." |
| 412 | (nth 2 position)) |
| 413 | |
| 414 | (defsubst posn-col-row (position) |
| 415 | "Return the column and row in POSITION, measured in characters. |
| 416 | POSITION should be a list of the form |
| 417 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 418 | as returned by the `event-start' and `event-end' functions." |
| 419 | (let* ((pair (nth 2 position)) |
| 420 | (window (posn-window position)) |
| 421 | (frame (if (framep window) window (window-frame window))) |
| 422 | (x (/ (car pair) (frame-char-width frame))) |
| 423 | (y (/ (cdr pair) (frame-char-height frame)))) |
| 424 | (cons x y))) |
| 425 | |
| 426 | (defsubst posn-timestamp (position) |
| 427 | "Return the timestamp of POSITION. |
| 428 | POSITION should be a list of the form |
| 429 | (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP) |
| 430 | as returned by the `event-start' and `event-end' functions." |
| 431 | (nth 3 position)) |
| 432 | |
| 433 | \f |
| 434 | ;;;; Obsolescent names for functions. |
| 435 | |
| 436 | (defalias 'dot 'point) |
| 437 | (defalias 'dot-marker 'point-marker) |
| 438 | (defalias 'dot-min 'point-min) |
| 439 | (defalias 'dot-max 'point-max) |
| 440 | (defalias 'window-dot 'window-point) |
| 441 | (defalias 'set-window-dot 'set-window-point) |
| 442 | (defalias 'read-input 'read-string) |
| 443 | (defalias 'send-string 'process-send-string) |
| 444 | (defalias 'send-region 'process-send-region) |
| 445 | (defalias 'show-buffer 'set-window-buffer) |
| 446 | (defalias 'buffer-flush-undo 'buffer-disable-undo) |
| 447 | (defalias 'eval-current-buffer 'eval-buffer) |
| 448 | (defalias 'compiled-function-p 'byte-code-function-p) |
| 449 | |
| 450 | ;; Some programs still use this as a function. |
| 451 | (defun baud-rate () |
| 452 | "Obsolete function returning the value of the `baud-rate' variable. |
| 453 | Please convert your programs to use the variable `baud-rate' directly." |
| 454 | baud-rate) |
| 455 | |
| 456 | \f |
| 457 | ;;;; Alternate names for functions - these are not being phased out. |
| 458 | |
| 459 | (defalias 'string= 'string-equal) |
| 460 | (defalias 'string< 'string-lessp) |
| 461 | (defalias 'move-marker 'set-marker) |
| 462 | (defalias 'eql 'eq) |
| 463 | (defalias 'not 'null) |
| 464 | (defalias 'rplaca 'setcar) |
| 465 | (defalias 'rplacd 'setcdr) |
| 466 | (defalias 'beep 'ding) ;preserve lingual purity |
| 467 | (defalias 'indent-to-column 'indent-to) |
| 468 | (defalias 'backward-delete-char 'delete-backward-char) |
| 469 | (defalias 'search-forward-regexp (symbol-function 're-search-forward)) |
| 470 | (defalias 'search-backward-regexp (symbol-function 're-search-backward)) |
| 471 | (defalias 'int-to-string 'number-to-string) |
| 472 | (defalias 'set-match-data 'store-match-data) |
| 473 | |
| 474 | ;;; Should this be an obsolete name? If you decide it should, you get |
| 475 | ;;; to go through all the sources and change them. |
| 476 | (defalias 'string-to-int 'string-to-number) |
| 477 | \f |
| 478 | ;;;; Hook manipulation functions. |
| 479 | |
| 480 | (defun run-hooks (&rest hooklist) |
| 481 | "Takes hook names and runs each one in turn. Major mode functions use this. |
| 482 | Each argument should be a symbol, a hook variable. |
| 483 | These symbols are processed in the order specified. |
| 484 | If a hook symbol has a non-nil value, that value may be a function |
| 485 | or a list of functions to be called to run the hook. |
| 486 | If the value is a function, it is called with no arguments. |
| 487 | If it is a list, the elements are called, in order, with no arguments." |
| 488 | (while hooklist |
| 489 | (let ((sym (car hooklist))) |
| 490 | (and (boundp sym) |
| 491 | (symbol-value sym) |
| 492 | (let ((value (symbol-value sym))) |
| 493 | (if (and (listp value) (not (eq (car value) 'lambda))) |
| 494 | (let ((functions value)) |
| 495 | (while value |
| 496 | (funcall (car value)) |
| 497 | (setq value (cdr value)))) |
| 498 | (funcall value))))) |
| 499 | (setq hooklist (cdr hooklist)))) |
| 500 | |
| 501 | (defun run-hook-with-args (hook &rest args) |
| 502 | "Run HOOK with the specified arguments ARGS. |
| 503 | HOOK should be a symbol, a hook variable. If HOOK has a non-nil |
| 504 | value, that value may be a function or a list of functions to be |
| 505 | called to run the hook. If the value is a function, it is called with |
| 506 | the given arguments and its return value is returned. If it is a list |
| 507 | of functions, those functions are called, in order, |
| 508 | with the given arguments ARGS. |
| 509 | It is best not to depend on the value return by `run-hook-with-args', |
| 510 | as that may change." |
| 511 | (and (boundp hook) |
| 512 | (symbol-value hook) |
| 513 | (let ((value (symbol-value hook))) |
| 514 | (if (and (listp value) (not (eq (car value) 'lambda))) |
| 515 | (mapcar '(lambda (foo) (apply foo args)) |
| 516 | value) |
| 517 | (apply value args))))) |
| 518 | |
| 519 | ;; Tell C code how to call this function. |
| 520 | (defconst run-hooks 'run-hooks |
| 521 | "Variable by which C primitives find the function `run-hooks'. |
| 522 | Don't change it.") |
| 523 | |
| 524 | (defun add-hook (hook function &optional append) |
| 525 | "Add to the value of HOOK the function FUNCTION. |
| 526 | FUNCTION is not added if already present. |
| 527 | FUNCTION is added (if necessary) at the beginning of the hook list |
| 528 | unless the optional argument APPEND is non-nil, in which case |
| 529 | FUNCTION is added at the end. |
| 530 | |
| 531 | HOOK should be a symbol, and FUNCTION may be any valid function. If |
| 532 | HOOK is void, it is first set to nil. If HOOK's value is a single |
| 533 | function, it is changed to a list of functions." |
| 534 | (or (boundp hook) (set hook nil)) |
| 535 | ;; If the hook value is a single function, turn it into a list. |
| 536 | (let ((old (symbol-value hook))) |
| 537 | (if (or (not (listp old)) (eq (car old) 'lambda)) |
| 538 | (set hook (list old)))) |
| 539 | (or (if (consp function) |
| 540 | (member function (symbol-value hook)) |
| 541 | (memq function (symbol-value hook))) |
| 542 | (set hook |
| 543 | (if append |
| 544 | (nconc (symbol-value hook) (list function)) |
| 545 | (cons function (symbol-value hook)))))) |
| 546 | |
| 547 | (defun remove-hook (hook function) |
| 548 | "Remove from the value of HOOK the function FUNCTION. |
| 549 | HOOK should be a symbol, and FUNCTION may be any valid function. If |
| 550 | FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the |
| 551 | list of hooks to run in HOOK, then nothing is done. See `add-hook'." |
| 552 | (if (or (not (boundp hook)) ;unbound symbol, or |
| 553 | (null (symbol-value hook)) ;value is nil, or |
| 554 | (null function)) ;function is nil, then |
| 555 | nil ;Do nothing. |
| 556 | (let ((hook-value (symbol-value hook))) |
| 557 | (if (consp hook-value) |
| 558 | (setq hook-value (delete function hook-value)) |
| 559 | (if (equal hook-value function) |
| 560 | (setq hook-value nil))) |
| 561 | (set hook hook-value)))) |
| 562 | \f |
| 563 | ;;;; Specifying things to do after certain files are loaded. |
| 564 | |
| 565 | (defun eval-after-load (file form) |
| 566 | "Arrange that, if FILE is ever loaded, FORM will be run at that time. |
| 567 | This makes or adds to an entry on `after-load-alist'. |
| 568 | It does nothing if FORM is already on the list for FILE. |
| 569 | FILE should be the name of a library, with no directory name." |
| 570 | (or (assoc file after-load-alist) |
| 571 | (setq after-load-alist (cons (list file) after-load-alist))) |
| 572 | (let ((elt (assoc file after-load-alist))) |
| 573 | (or (member form (cdr elt)) |
| 574 | (nconc elt (list form)))) |
| 575 | form) |
| 576 | |
| 577 | (defun eval-next-after-load (file) |
| 578 | "Read the following input sexp, and run it whenever FILE is loaded. |
| 579 | This makes or adds to an entry on `after-load-alist'. |
| 580 | FILE should be the name of a library, with no directory name." |
| 581 | (eval-after-load file (read))) |
| 582 | |
| 583 | \f |
| 584 | ;;;; Input and display facilities. |
| 585 | |
| 586 | (defun read-quoted-char (&optional prompt) |
| 587 | "Like `read-char', except that if the first character read is an octal |
| 588 | digit, we read up to two more octal digits and return the character |
| 589 | represented by the octal number consisting of those digits. |
| 590 | Optional argument PROMPT specifies a string to use to prompt the user." |
| 591 | (let ((count 0) (code 0) char) |
| 592 | (while (< count 3) |
| 593 | (let ((inhibit-quit (zerop count)) |
| 594 | (help-form nil)) |
| 595 | (and prompt (message "%s-" prompt)) |
| 596 | (setq char (read-char)) |
| 597 | (if inhibit-quit (setq quit-flag nil))) |
| 598 | (cond ((null char)) |
| 599 | ((and (<= ?0 char) (<= char ?7)) |
| 600 | (setq code (+ (* code 8) (- char ?0)) |
| 601 | count (1+ count)) |
| 602 | (and prompt (message (setq prompt |
| 603 | (format "%s %c" prompt char))))) |
| 604 | ((> count 0) |
| 605 | (setq unread-command-events (list char) count 259)) |
| 606 | (t (setq code char count 259)))) |
| 607 | ;; Turn a meta-character into a character with the 0200 bit set. |
| 608 | (logior (if (/= (logand code (lsh 1 23)) 0) 128 0) |
| 609 | (logand 255 code)))) |
| 610 | |
| 611 | (defun force-mode-line-update (&optional all) |
| 612 | "Force the mode-line of the current buffer to be redisplayed. |
| 613 | With optional non-nil ALL, force redisplay of all mode-lines." |
| 614 | (if all (save-excursion (set-buffer (other-buffer)))) |
| 615 | (set-buffer-modified-p (buffer-modified-p))) |
| 616 | |
| 617 | (defun momentary-string-display (string pos &optional exit-char message) |
| 618 | "Momentarily display STRING in the buffer at POS. |
| 619 | Display remains until next character is typed. |
| 620 | If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; |
| 621 | otherwise it is then available as input (as a command if nothing else). |
| 622 | Display MESSAGE (optional fourth arg) in the echo area. |
| 623 | If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." |
| 624 | (or exit-char (setq exit-char ?\ )) |
| 625 | (let ((buffer-read-only nil) |
| 626 | ;; Don't modify the undo list at all. |
| 627 | (buffer-undo-list t) |
| 628 | (modified (buffer-modified-p)) |
| 629 | (name buffer-file-name) |
| 630 | insert-end) |
| 631 | (unwind-protect |
| 632 | (progn |
| 633 | (save-excursion |
| 634 | (goto-char pos) |
| 635 | ;; defeat file locking... don't try this at home, kids! |
| 636 | (setq buffer-file-name nil) |
| 637 | (insert-before-markers string) |
| 638 | (setq insert-end (point)) |
| 639 | ;; If the message end is off screen, recenter now. |
| 640 | (if (> (window-end) insert-end) |
| 641 | (recenter (/ (window-height) 2))) |
| 642 | ;; If that pushed message start off the screen, |
| 643 | ;; scroll to start it at the top of the screen. |
| 644 | (move-to-window-line 0) |
| 645 | (if (> (point) pos) |
| 646 | (progn |
| 647 | (goto-char pos) |
| 648 | (recenter 0)))) |
| 649 | (message (or message "Type %s to continue editing.") |
| 650 | (single-key-description exit-char)) |
| 651 | (let ((char (read-event))) |
| 652 | (or (eq char exit-char) |
| 653 | (setq unread-command-events (list char))))) |
| 654 | (if insert-end |
| 655 | (save-excursion |
| 656 | (delete-region pos insert-end))) |
| 657 | (setq buffer-file-name name) |
| 658 | (set-buffer-modified-p modified)))) |
| 659 | |
| 660 | \f |
| 661 | ;;;; Miscellanea. |
| 662 | |
| 663 | (defun ignore (&rest ignore) |
| 664 | (interactive) |
| 665 | "Do nothing. |
| 666 | Accept any number of arguments, but ignore them." |
| 667 | nil) |
| 668 | |
| 669 | (defun error (&rest args) |
| 670 | "Signal an error, making error message by passing all args to `format'." |
| 671 | (while t |
| 672 | (signal 'error (list (apply 'format args))))) |
| 673 | |
| 674 | (defalias 'user-original-login-name 'user-login-name) |
| 675 | |
| 676 | (defun start-process-shell-command (name buffer &rest args) |
| 677 | "Start a program in a subprocess. Return the process object for it. |
| 678 | Args are NAME BUFFER COMMAND &rest COMMAND-ARGS. |
| 679 | NAME is name for process. It is modified if necessary to make it unique. |
| 680 | BUFFER is the buffer or (buffer-name) to associate with the process. |
| 681 | Process output goes at end of that buffer, unless you specify |
| 682 | an output stream or filter function to handle the output. |
| 683 | BUFFER may be also nil, meaning that this process is not associated |
| 684 | with any buffer |
| 685 | Third arg is command name, the name of a shell command. |
| 686 | Remaining arguments are the arguments for the command. |
| 687 | Wildcards and redirection are handled as usual in the shell." |
| 688 | (if (eq system-type 'vax-vms) |
| 689 | (apply 'start-process name buffer args) |
| 690 | (start-process name buffer shell-file-name "-c" |
| 691 | (concat "exec " (mapconcat 'identity args " "))))) |
| 692 | |
| 693 | (defmacro save-match-data (&rest body) |
| 694 | "Execute the BODY forms, restoring the global value of the match data." |
| 695 | (let ((original (make-symbol "match-data"))) |
| 696 | (list |
| 697 | 'let (list (list original '(match-data))) |
| 698 | (list 'unwind-protect |
| 699 | (cons 'progn body) |
| 700 | (list 'store-match-data original))))) |
| 701 | |
| 702 | (defun shell-quote-argument (argument) |
| 703 | "Quote an argument for passing as argument to an inferior shell." |
| 704 | ;; Quote everything except POSIX filename characters. |
| 705 | ;; This should be safe enough even for really weird shells. |
| 706 | (let ((result "") (start 0) end) |
| 707 | (while (string-match "[^-0-9a-zA-Z_./]" argument start) |
| 708 | (setq end (match-beginning 0) |
| 709 | result (concat result (substring argument start end) |
| 710 | "\\" (substring argument end (1+ end))) |
| 711 | start (1+ end))) |
| 712 | (concat result (substring argument start)))) |
| 713 | |
| 714 | (defun make-syntax-table (&optional oldtable) |
| 715 | "Return a new syntax table. |
| 716 | It inherits all letters and control characters from the standard |
| 717 | syntax table; other characters are copied from the standard syntax table." |
| 718 | (if oldtable |
| 719 | (copy-syntax-table oldtable) |
| 720 | (let ((table (copy-syntax-table)) |
| 721 | i) |
| 722 | (setq i 0) |
| 723 | (while (<= i 31) |
| 724 | (aset table i 13) |
| 725 | (setq i (1+ i))) |
| 726 | (setq i ?A) |
| 727 | (while (<= i ?Z) |
| 728 | (aset table i 13) |
| 729 | (setq i (1+ i))) |
| 730 | (setq i ?a) |
| 731 | (while (<= i ?z) |
| 732 | (aset table i 13) |
| 733 | (setq i (1+ i))) |
| 734 | (setq i 128) |
| 735 | (while (<= i 255) |
| 736 | (aset table i 13) |
| 737 | (setq i (1+ i))) |
| 738 | table))) |
| 739 | |
| 740 | ;; now in fns.c |
| 741 | ;(defun nth (n list) |
| 742 | ; "Returns the Nth element of LIST. |
| 743 | ;N counts from zero. If LIST is not that long, nil is returned." |
| 744 | ; (car (nthcdr n list))) |
| 745 | ; |
| 746 | ;(defun copy-alist (alist) |
| 747 | ; "Return a copy of ALIST. |
| 748 | ;This is a new alist which represents the same mapping |
| 749 | ;from objects to objects, but does not share the alist structure with ALIST. |
| 750 | ;The objects mapped (cars and cdrs of elements of the alist) |
| 751 | ;are shared, however." |
| 752 | ; (setq alist (copy-sequence alist)) |
| 753 | ; (let ((tail alist)) |
| 754 | ; (while tail |
| 755 | ; (if (consp (car tail)) |
| 756 | ; (setcar tail (cons (car (car tail)) (cdr (car tail))))) |
| 757 | ; (setq tail (cdr tail)))) |
| 758 | ; alist) |
| 759 | |
| 760 | ;;; subr.el ends here |
| 761 | |