lisp/subr.el

   1 ;; Basic lisp subroutines for Emacs
   2 ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
   3
   4 ;; This file is part of GNU Emacs.
   5
   6 ;; GNU Emacs is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 1, or (at your option)
   9 ;; any later version.
  10
  11 ;; GNU Emacs is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19
  20
  21 (defun one-window-p (&optional arg)
  22   "Returns non-nil if there is only one window.
  23 Optional arg NOMINI non-nil means don't count the minibuffer
  24 even if it is active."
  25   (eq (selected-window)
  26       (next-window (selected-window) (if arg 'arg))))
  27
  28 (defun walk-windows (proc &optional minibuf all-screens)
  29   "Cycle through all visible windows, calling PROC for each one.
  30 PROC is called with a window as argument.
  31 Optional second arg MINIBUF t means count the minibuffer window
  32 even if not active.  If MINIBUF is neither t nor nil it means
  33 not to count the minibuffer even if it is active.
  34 Optional third arg ALL-SCREENS t means include all windows in all screens;
  35 otherwise cycle within the selected screen."
  36   (let* ((walk-windows-start (selected-window))
  37          (walk-windows-current walk-windows-start))
  38     (while (progn
  39              (setq walk-windows-current
  40                    (next-window walk-windows-current minibuf all-screens))
  41              (funcall proc walk-windows-current)
  42              (not (eq walk-windows-current walk-windows-start))))))
  43
  44 (defun read-quoted-char (&optional prompt)
  45   "Like `read-char', except that if the first character read is an octal
  46 digit, we read up to two more octal digits and return the character
  47 represented by the octal number consisting of those digits.
  48 Optional argument PROMPT specifies a string to use to prompt the user."
  49   (let ((count 0) (code 0) char)
  50     (while (< count 3)
  51       (let ((inhibit-quit (zerop count))
  52             (help-form nil))
  53         (and prompt (message "%s-" prompt))
  54         (setq char (read-char))
  55         (if inhibit-quit (setq quit-flag nil)))
  56       (cond ((null char))
  57             ((and (<= ?0 char) (<= char ?7))
  58              (setq code (+ (* code 8) (- char ?0))
  59                    count (1+ count))
  60              (and prompt (message (setq prompt
  61                                         (format "%s %c" prompt char)))))
  62             ((> count 0)
  63              (setq unread-command-char char count 259))
  64             (t (setq code char count 259))))
  65     (logand 255 code)))
  66
  67 (defun error (&rest args)
  68   "Signal an error, making error message by passing all args to `format'."
  69   (while t
  70     (signal 'error (list (apply 'format args)))))
  71
  72 (defun undefined ()
  73   (interactive)
  74   (ding))
  75
  76 ;Prevent the \{...} documentation construct
  77 ;from mentioning keys that run this command.
  78 (put 'undefined 'suppress-keymap t)
  79
  80 (defun suppress-keymap (map &optional nodigits)
  81   "Make MAP override all normally self-inserting keys to be undefined.
  82 Normally, as an exception, digits and minus-sign are set to make prefix args,
  83 but optional second arg NODIGITS non-nil treats them like other chars."
  84   (let ((i 0))
  85     (while (<= i 127)
  86       (if (eql (lookup-key global-map (char-to-string i)) 'self-insert-command)
  87           (define-key map (char-to-string i) 'undefined))
  88       (setq i (1+ i))))
  89   (or nodigits
  90       (let (loop)
  91         (define-key map "-" 'negative-argument)
  92         ;; Make plain numbers do numeric args.
  93         (setq loop ?0)
  94         (while (<= loop ?9)
  95           (define-key map (char-to-string loop) 'digit-argument)
  96           (setq loop (1+ loop))))))
  97
  98 ;; now in fns.c
  99 ;(defun nth (n list)
 100 ;  "Returns the Nth element of LIST.
 101 ;N counts from zero.  If LIST is not that long, nil is returned."
 102 ;  (car (nthcdr n list)))
 103 ;
 104 ;(defun copy-alist (alist)
 105 ;  "Return a copy of ALIST.
 106 ;This is a new alist which represents the same mapping
 107 ;from objects to objects, but does not share the alist structure with ALIST.
 108 ;The objects mapped (cars and cdrs of elements of the alist)
 109 ;are shared, however."
 110 ;  (setq alist (copy-sequence alist))
 111 ;  (let ((tail alist))
 112 ;    (while tail
 113 ;      (if (consp (car tail))
 114 ;         (setcar tail (cons (car (car tail)) (cdr (car tail)))))
 115 ;      (setq tail (cdr tail))))
 116 ;  alist)
 117
 118 ;Moved to keymap.c
 119 ;(defun copy-keymap (keymap)
 120 ;  "Return a copy of KEYMAP"
 121 ;  (while (not (keymapp keymap))
 122 ;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
 123 ;  (if (vectorp keymap)
 124 ;      (copy-sequence keymap)
 125 ;      (copy-alist keymap)))
 126
 127 (defun substitute-key-definition (olddef newdef keymap)
 128   "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
 129 In other words, OLDDEF is replaced with NEWDEF where ever it appears.
 130 Prefix keymaps reached from KEYMAP are not checked recursively;
 131 perhaps they ought to be."
 132   (if (arrayp keymap)
 133       (let ((len (length keymap))
 134             (i 0))
 135         (while (< i len)
 136           (if (eq (aref keymap i) olddef)
 137               (aset keymap i newdef))
 138           (setq i (1+ i))))
 139     (while keymap
 140       (if (eq (cdr-safe (car-safe keymap)) olddef)
 141           (setcdr (car keymap) newdef))
 142       (setq keymap (cdr keymap)))))
 143
 144 ;; Avoids useless byte-compilation.
 145 ;; In the future, would be better to fix byte compiler
 146 ;; not to really compile in cases like this,
 147 ;; and use defun here.
 148 (fset 'ignore '(lambda (&rest ignore)
 149                  "Do nothing.
 150 Accept any number of arguments, but ignore them."
 151                  nil))
 152
 153 \f
 154 ; old names
 155 (fset 'make-syntax-table 'copy-syntax-table)
 156 (fset 'dot 'point)
 157 (fset 'dot-marker 'point-marker)
 158 (fset 'dot-min 'point-min)
 159 (fset 'dot-max 'point-max)
 160 (fset 'window-dot 'window-point)
 161 (fset 'set-window-dot 'set-window-point)
 162 (fset 'read-input 'read-string)
 163 (fset 'send-string 'process-send-string)
 164 (fset 'send-region 'process-send-region)
 165 (fset 'show-buffer 'set-window-buffer)
 166 (fset 'buffer-flush-undo 'buffer-disable-undo)
 167
 168 ; alternate names
 169 (fset 'string= 'string-equal)
 170 (fset 'string< 'string-lessp)
 171 (fset 'move-marker 'set-marker)
 172 (fset 'eql 'eq)
 173 (fset 'not 'null)
 174 (fset 'numberp 'integerp)
 175 (fset 'rplaca 'setcar)
 176 (fset 'rplacd 'setcdr)
 177 (fset 'beep 'ding) ;preserve lingual purtity
 178 (fset 'indent-to-column 'indent-to)
 179 (fset 'backward-delete-char 'delete-backward-char)
 180 (fset 'search-forward-regexp (symbol-function 're-search-forward))
 181 (fset 'search-backward-regexp (symbol-function 're-search-backward))
 182 \f
 183 ;;; global-map, esc-map, and ctl-x-map have their values set up
 184 ;;; in keymap.c.
 185 (defvar global-map nil
 186   "Default global keymap mapping Emacs keyboard input into commands.
 187 The value is a keymap which is usually (but not necessarily) Emacs's
 188 global map.")
 189
 190 (defvar esc-map nil
 191   "Default keymap for ESC (meta) commands.
 192 The normal global definition of the character ESC indirects to this keymap.")
 193
 194 (defvar ctl-x-map nil
 195   "Default keymap for C-x commands.
 196 The normal global definition of the character C-x indirects to this keymap.")
 197
 198 (defvar ctl-x-4-map (make-sparse-keymap)
 199   "Keymap for subcommands of C-x 4")
 200 (fset 'ctl-x-4-prefix ctl-x-4-map)
 201 (define-key ctl-x-map "4" 'ctl-x-4-prefix)
 202
 203 (defvar ctl-x-3-map (make-sparse-keymap)
 204   "Keymap for screen commands.")
 205 (fset 'ctl-x-3-prefix ctl-x-3-map)
 206 (define-key ctl-x-map "3" 'ctl-x-3-prefix)
 207
 208 \f
 209 (defun run-hooks (&rest hooklist)
 210   "Takes hook names and runs each one in turn.  Major mode functions use this.
 211 Each argument should be a symbol, a hook variable.
 212 These symbols are processed in the order specified.
 213 If a hook symbol has a non-nil value, that value may be a function
 214 or a list of functions to be called to run the hook.
 215 If the value is a function, it is called with no arguments.
 216 If it is a list, the elements are called, in order, with no arguments."
 217   (while hooklist
 218     (let ((sym (car hooklist)))
 219       (and (boundp sym)
 220            (symbol-value sym)
 221            (let ((value (symbol-value sym)))
 222              (if (and (listp value) (not (eq (car value) 'lambda)))
 223                  (mapcar 'funcall value)
 224                (funcall value)))))
 225     (setq hooklist (cdr hooklist))))
 226
 227 ;; Tell C code how to call this function.
 228 (defconst run-hooks 'run-hooks
 229   "Variable by which C primitives find the function `run-hooks'.
 230 Don't change it.")
 231
 232 (defun add-hook (hook function)
 233   "Add to the value of HOOK the function FUNCTION unless already present.
 234 HOOK should be a symbol, and FUNCTION may be any valid function.
 235 HOOK's value should be a list of functions, not a single function.
 236 If HOOK is void, it is first set to nil."
 237   (or (boundp hook) (set hook nil))
 238   (or (if (consp function)
 239           ;; Clever way to tell whether a given lambda-expression
 240           ;; is equal to anything in the hook.
 241           (let ((tail (assoc (cdr function) (symbol-value hook))))
 242             (equal function tail))
 243         (memq function (symbol-value hook)))
 244       (set hook (cons function (symbol-value hook)))))
 245 \f
 246 (defun momentary-string-display (string pos &optional exit-char message)
 247   "Momentarily display STRING in the buffer at POS.
 248 Display remains until next character is typed.
 249 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
 250 otherwise it is then available as input (as a command if nothing else).
 251 Display MESSAGE (optional fourth arg) in the echo area.
 252 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
 253   (or exit-char (setq exit-char ?\ ))
 254   (let ((buffer-read-only nil)
 255         (modified (buffer-modified-p))
 256         (name buffer-file-name)
 257         insert-end)
 258     (unwind-protect
 259         (progn
 260           (save-excursion
 261             (goto-char pos)
 262             ;; defeat file locking... don't try this at home, kids!
 263             (setq buffer-file-name nil)
 264             (insert-before-markers string)
 265             (setq insert-end (point)))
 266           (message (or message "Type %s to continue editing.")
 267                    (single-key-description exit-char))
 268           (let ((char (read-char)))
 269             (or (eq char exit-char)
 270                 (setq unread-command-char char))))
 271       (if insert-end
 272           (save-excursion
 273             (delete-region pos insert-end)))
 274       (setq buffer-file-name name)
 275       (set-buffer-modified-p modified))))
 276
 277 (defun start-process-shell-command (name buffer &rest args)
 278   "Start a program in a subprocess.  Return the process object for it.
 279 Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
 280 NAME is name for process.  It is modified if necessary to make it unique.
 281 BUFFER is the buffer or (buffer-name) to associate with the process.
 282  Process output goes at end of that buffer, unless you specify
 283  an output stream or filter function to handle the output.
 284  BUFFER may be also nil, meaning that this process is not associated
 285  with any buffer
 286 Third arg is command name, the name of a shell command.
 287 Remaining arguments are the arguments for the command.
 288 Wildcards and redirection are handle as usual in the shell."
 289   (if (eq system-type 'vax-vms)
 290       (apply 'start-process name buffer args)
 291     (start-process name buffer shell-file-name "-c"
 292                    (concat "exec " (mapconcat 'identity args " ")))))
 293 \f
 294 (defun eval-after-load (file form)
 295   "Arrange that, if FILE is ever loaded, FORM will be run at that time.
 296 This makes or adds to an entry on `after-load-alist'.
 297 FILE should be the name of a library, with no directory name."
 298   (or (assoc file after-load-alist)
 299       (setq after-load-alist (cons (list file) after-load-alist)))
 300   (nconc (assoc file after-load-alist) (list form))
 301   form)
 302
 303 (defun eval-next-after-load (file)
 304   "Read the following input sexp, and run it whenever FILE is loaded.
 305 This makes or adds to an entry on `after-load-alist'.
 306 FILE should be the name of a library, with no directory name."
 307   (eval-after-load file (read)))
 308
 309 (defmacro defun-inline (name args &rest body)
 310   "Create an \"inline defun\" (actually a macro).
 311 Use just like `defun'."
 312   (nconc (list 'defmacro name '(&rest args))
 313          (if (stringp (car body))
 314              (prog1 (list (car body))
 315                (setq body (or (cdr body) body))))
 316          (list (list 'cons (list 'quote
 317                                  (cons 'lambda (cons args body)))
 318                      'args))))
 319 \f
 320 (defun user-original-login-name ()
 321   "Return user's login name from original login.
 322 This tries to remain unaffected by `su', by looking in environment variables."
 323   (or (getenv "LOGNAME") (getenv "USER") (user-login-name)))
 324 \f
 325 (defun force-mode-line-update (&optional all)
 326   "Force the mode-line of the current buffer to be redisplayed.
 327 With optional non-nil ALL then force then force redisplay of all mode-lines."
 328   (if all (save-excursion (set-buffer (other-buffer))))
 329   (set-buffer-modified-p (buffer-modified-p)))
 330
 331 (defun keyboard-translate (from to)
 332   "Translate character FROM to TO at a low level.
 333 This function creates a `keyboard-translate-table' if necessary
 334 and then modifies one entry in it."
 335   (or (boundp 'keyboard-translate-table)
 336       (let ((table (make-string 256))
 337             (i 0))
 338         (while (< i 256)
 339           (aset table i i)
 340           (setq i (1+ i)))
 341         (setq keyboard-translate-table table)))
 342   (aset keyboard-translate-table from to))
 343
 344 \f
 345 (defmacro lambda (&rest cdr)
 346   (` (function (lambda (,@ cdr)))))