lisp/subr.el

   1 ;;; subr.el --- basic lisp subroutines for Emacs
   2
   3 ;;; Copyright (C) 1985, 1986, 1992 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 (defun one-window-p (&optional nomini)
  24   "Returns non-nil if there is only one window.
  25 Optional arg NOMINI non-nil means don't count the minibuffer
  26 even if it is active."
  27   (let ((base-window (selected-window)))
  28     (if (and nomini (eq base-window (minibuffer-window)))
  29         (setq base-window (next-window base-window)))
  30     (eq base-window
  31         (next-window base-window (if nomini 'arg)))))
  32
  33 (defun walk-windows (proc &optional minibuf all-frames)
  34   "Cycle through all visible windows, calling PROC for each one.
  35 PROC is called with a window as argument.
  36 Optional second arg MINIBUF t means count the minibuffer window
  37 even if not active.  If MINIBUF is neither t nor nil it means
  38 not to count the minibuffer even if it is active.
  39 Optional third arg ALL-FRAMES t means include all windows in all frames;
  40 otherwise cycle within the selected frame."
  41   (let* ((walk-windows-start (selected-window))
  42          (walk-windows-current walk-windows-start))
  43     (while (progn
  44              (setq walk-windows-current
  45                    (next-window walk-windows-current minibuf all-frames))
  46              (funcall proc walk-windows-current)
  47              (not (eq walk-windows-current walk-windows-start))))))
  48
  49 (defun read-quoted-char (&optional prompt)
  50   "Like `read-char', except that if the first character read is an octal
  51 digit, we read up to two more octal digits and return the character
  52 represented by the octal number consisting of those digits.
  53 Optional argument PROMPT specifies a string to use to prompt the user."
  54   (let ((count 0) (code 0) char)
  55     (while (< count 3)
  56       (let ((inhibit-quit (zerop count))
  57             (help-form nil))
  58         (and prompt (message "%s-" prompt))
  59         (setq char (read-char))
  60         (if inhibit-quit (setq quit-flag nil)))
  61       (cond ((null char))
  62             ((and (<= ?0 char) (<= char ?7))
  63              (setq code (+ (* code 8) (- char ?0))
  64                    count (1+ count))
  65              (and prompt (message (setq prompt
  66                                         (format "%s %c" prompt char)))))
  67             ((> count 0)
  68              (setq unread-command-events (list char) count 259))
  69             (t (setq code char count 259))))
  70     (logand 255 code)))
  71
  72 (defun error (&rest args)
  73   "Signal an error, making error message by passing all args to `format'."
  74   (while t
  75     (signal 'error (list (apply 'format args)))))
  76
  77 (defun undefined ()
  78   (interactive)
  79   (ding))
  80
  81 ;; Some programs still use this as a function.
  82 (defun baud-rate ()
  83   "Obsolete function returning the value of the `baud-rate' variable."
  84   baud-rate)
  85
  86 ;Prevent the \{...} documentation construct
  87 ;from mentioning keys that run this command.
  88 (put 'undefined 'suppress-keymap t)
  89
  90 (defun suppress-keymap (map &optional nodigits)
  91   "Make MAP override all normally self-inserting keys to be undefined.
  92 Normally, as an exception, digits and minus-sign are set to make prefix args,
  93 but optional second arg NODIGITS non-nil treats them like other chars."
  94   (let ((i 0))
  95     (while (<= i 127)
  96       (if (eql (lookup-key global-map (char-to-string i)) 'self-insert-command)
  97           (define-key map (char-to-string i) 'undefined))
  98       (setq i (1+ i))))
  99   (or nodigits
 100       (let (loop)
 101         (define-key map "-" 'negative-argument)
 102         ;; Make plain numbers do numeric args.
 103         (setq loop ?0)
 104         (while (<= loop ?9)
 105           (define-key map (char-to-string loop) 'digit-argument)
 106           (setq loop (1+ loop))))))
 107
 108 ;; now in fns.c
 109 ;(defun nth (n list)
 110 ;  "Returns the Nth element of LIST.
 111 ;N counts from zero.  If LIST is not that long, nil is returned."
 112 ;  (car (nthcdr n list)))
 113 ;
 114 ;(defun copy-alist (alist)
 115 ;  "Return a copy of ALIST.
 116 ;This is a new alist which represents the same mapping
 117 ;from objects to objects, but does not share the alist structure with ALIST.
 118 ;The objects mapped (cars and cdrs of elements of the alist)
 119 ;are shared, however."
 120 ;  (setq alist (copy-sequence alist))
 121 ;  (let ((tail alist))
 122 ;    (while tail
 123 ;      (if (consp (car tail))
 124 ;         (setcar tail (cons (car (car tail)) (cdr (car tail)))))
 125 ;      (setq tail (cdr tail))))
 126 ;  alist)
 127
 128 ;Moved to keymap.c
 129 ;(defun copy-keymap (keymap)
 130 ;  "Return a copy of KEYMAP"
 131 ;  (while (not (keymapp keymap))
 132 ;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
 133 ;  (if (vectorp keymap)
 134 ;      (copy-sequence keymap)
 135 ;      (copy-alist keymap)))
 136
 137 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
 138   "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
 139 In other words, OLDDEF is replaced with NEWDEF where ever it appears.
 140 If optional fourth argument OLDMAP is specified, we redefine
 141 in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
 142   (or prefix (setq prefix ""))
 143   (let* ((scan (or oldmap keymap))
 144          (vec1 (vector nil))
 145          (prefix1 (vconcat prefix vec1)))
 146     ;; Scan OLDMAP, finding each char or event-symbol that
 147     ;; has any definition, and act on it with hack-key.
 148     (while (consp scan)
 149       (if (consp (car scan))
 150           (let ((char (car (car scan)))
 151                 (defn (cdr (car scan))))
 152             ;; The inside of this let duplicates exactly
 153             ;; the inside of the following let that handles array elements.
 154             (aset vec1 0 char)
 155             (aset prefix1 (length prefix) char)
 156             (let (inner-def)
 157               ;; Skip past menu-prompt.
 158               (while (stringp (car-safe defn))
 159                 (setq defn (cdr defn)))
 160               (setq inner-def defn)
 161               (while (and (symbolp inner-def)
 162                           (fboundp inner-def))
 163                 (setq inner-def (symbol-function inner-def)))
 164               (if (eq defn olddef)
 165                   (define-key keymap prefix1 newdef)
 166                 (if (keymapp defn)
 167                     (substitute-key-definition olddef newdef keymap
 168                                                inner-def
 169                                                prefix1)))))
 170         (if (arrayp (car scan))
 171             (let* ((array (car scan))
 172                    (len (length array))
 173                    (i 0))
 174               (while (< i len)
 175                 (let ((char i) (defn (aref array i)))
 176                   ;; The inside of this let duplicates exactly
 177                   ;; the inside of the previous let.
 178                   (aset vec1 0 char)
 179                   (aset prefix1 (length prefix) char)
 180                   (let (inner-def)
 181                     ;; Skip past menu-prompt.
 182                     (while (stringp (car-safe defn))
 183                       (setq defn (cdr defn)))
 184                     (setq inner-def defn)
 185                     (while (and (symbolp inner-def)
 186                                 (fboundp inner-def))
 187                       (setq inner-def (symbol-function inner-def)))
 188                     (if (eq defn olddef)
 189                         (define-key keymap prefix1 newdef)
 190                       (if (keymapp defn)
 191                           (substitute-key-definition olddef newdef keymap
 192                                                      inner-def
 193                                                      prefix1)))))
 194                 (setq i (1+ i))))))
 195       (setq scan (cdr scan)))))
 196
 197 (defmacro save-match-data (&rest body)
 198   "Execute the BODY forms, restoring the global value of the match data."
 199   (let ((original (make-symbol "match-data")))
 200     (list
 201      'let (list (list original '(match-data)))
 202      (list 'unwind-protect
 203            (cons 'progn body)
 204            (list 'store-match-data original)))))
 205
 206 (defun ignore (&rest ignore)
 207   "Do nothing.
 208 Accept any number of arguments, but ignore them."
 209   nil)
 210 \f
 211 ; old names
 212 (fset 'make-syntax-table 'copy-syntax-table)
 213 (fset 'dot 'point)
 214 (fset 'dot-marker 'point-marker)
 215 (fset 'dot-min 'point-min)
 216 (fset 'dot-max 'point-max)
 217 (fset 'window-dot 'window-point)
 218 (fset 'set-window-dot 'set-window-point)
 219 (fset 'read-input 'read-string)
 220 (fset 'send-string 'process-send-string)
 221 (fset 'send-region 'process-send-region)
 222 (fset 'show-buffer 'set-window-buffer)
 223 (fset 'buffer-flush-undo 'buffer-disable-undo)
 224 (fset 'eval-current-buffer 'eval-buffer)
 225 (fset 'compiled-function-p 'byte-code-function-p)
 226
 227 ; alternate names
 228 (fset 'string= 'string-equal)
 229 (fset 'string< 'string-lessp)
 230 (fset 'move-marker 'set-marker)
 231 (fset 'eql 'eq)
 232 (fset 'not 'null)
 233 (fset 'rplaca 'setcar)
 234 (fset 'rplacd 'setcdr)
 235 (fset 'beep 'ding) ;preserve lingual purtity
 236 (fset 'indent-to-column 'indent-to)
 237 (fset 'backward-delete-char 'delete-backward-char)
 238 (fset 'search-forward-regexp (symbol-function 're-search-forward))
 239 (fset 'search-backward-regexp (symbol-function 're-search-backward))
 240 \f
 241 ;;; global-map, esc-map, and ctl-x-map have their values set up
 242 ;;; in keymap.c.
 243 (defvar global-map nil
 244   "Default global keymap mapping Emacs keyboard input into commands.
 245 The value is a keymap which is usually (but not necessarily) Emacs's
 246 global map.")
 247
 248 (defvar esc-map nil
 249   "Default keymap for ESC (meta) commands.
 250 The normal global definition of the character ESC indirects to this keymap.")
 251
 252 (defvar ctl-x-map nil
 253   "Default keymap for C-x commands.
 254 The normal global definition of the character C-x indirects to this keymap.")
 255
 256 (defvar ctl-x-4-map (make-sparse-keymap)
 257   "Keymap for subcommands of C-x 4")
 258 (fset 'ctl-x-4-prefix ctl-x-4-map)
 259 (define-key ctl-x-map "4" 'ctl-x-4-prefix)
 260
 261 (defvar ctl-x-5-map (make-sparse-keymap)
 262   "Keymap for frame commands.")
 263 (fset 'ctl-x-5-prefix ctl-x-5-map)
 264 (define-key ctl-x-map "5" 'ctl-x-5-prefix)
 265
 266 \f
 267 (defun run-hooks (&rest hooklist)
 268   "Takes hook names and runs each one in turn.  Major mode functions use this.
 269 Each argument should be a symbol, a hook variable.
 270 These symbols are processed in the order specified.
 271 If a hook symbol has a non-nil value, that value may be a function
 272 or a list of functions to be called to run the hook.
 273 If the value is a function, it is called with no arguments.
 274 If it is a list, the elements are called, in order, with no arguments."
 275   (while hooklist
 276     (let ((sym (car hooklist)))
 277       (and (boundp sym)
 278            (symbol-value sym)
 279            (let ((value (symbol-value sym)))
 280              (if (and (listp value) (not (eq (car value) 'lambda)))
 281                  (mapcar 'funcall value)
 282                (funcall value)))))
 283     (setq hooklist (cdr hooklist))))
 284
 285 ;; Tell C code how to call this function.
 286 (defconst run-hooks 'run-hooks
 287   "Variable by which C primitives find the function `run-hooks'.
 288 Don't change it.")
 289
 290 (defun add-hook (hook function)
 291   "Add to the value of HOOK the function FUNCTION unless already present.
 292 HOOK should be a symbol, and FUNCTION may be any valid function.
 293 HOOK's value should be a list of functions, not a single function.
 294 If HOOK is void, it is first set to nil."
 295   (or (boundp hook) (set hook nil))
 296   (or (if (consp function)
 297           ;; Clever way to tell whether a given lambda-expression
 298           ;; is equal to anything in the hook.
 299           (let ((tail (assoc (cdr function) (symbol-value hook))))
 300             (equal function tail))
 301         (memq function (symbol-value hook)))
 302       (set hook (cons function (symbol-value hook)))))
 303 \f
 304 (defun momentary-string-display (string pos &optional exit-char message)
 305   "Momentarily display STRING in the buffer at POS.
 306 Display remains until next character is typed.
 307 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
 308 otherwise it is then available as input (as a command if nothing else).
 309 Display MESSAGE (optional fourth arg) in the echo area.
 310 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
 311   (or exit-char (setq exit-char ?\ ))
 312   (let ((buffer-read-only nil)
 313         (modified (buffer-modified-p))
 314         (name buffer-file-name)
 315         insert-end)
 316     (unwind-protect
 317         (progn
 318           (save-excursion
 319             (goto-char pos)
 320             ;; defeat file locking... don't try this at home, kids!
 321             (setq buffer-file-name nil)
 322             (insert-before-markers string)
 323             (setq insert-end (point)))
 324           (message (or message "Type %s to continue editing.")
 325                    (single-key-description exit-char))
 326           (let ((char (read-char)))
 327             (or (eq char exit-char)
 328                 (setq unread-command-events (list char)))))
 329       (if insert-end
 330           (save-excursion
 331             (delete-region pos insert-end)))
 332       (setq buffer-file-name name)
 333       (set-buffer-modified-p modified))))
 334
 335 (defun start-process-shell-command (name buffer &rest args)
 336   "Start a program in a subprocess.  Return the process object for it.
 337 Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
 338 NAME is name for process.  It is modified if necessary to make it unique.
 339 BUFFER is the buffer or (buffer-name) to associate with the process.
 340  Process output goes at end of that buffer, unless you specify
 341  an output stream or filter function to handle the output.
 342  BUFFER may be also nil, meaning that this process is not associated
 343  with any buffer
 344 Third arg is command name, the name of a shell command.
 345 Remaining arguments are the arguments for the command.
 346 Wildcards and redirection are handle as usual in the shell."
 347   (if (eq system-type 'vax-vms)
 348       (apply 'start-process name buffer args)
 349     (start-process name buffer shell-file-name "-c"
 350                    (concat "exec " (mapconcat 'identity args " ")))))
 351 \f
 352 (defun eval-after-load (file form)
 353   "Arrange that, if FILE is ever loaded, FORM will be run at that time.
 354 This makes or adds to an entry on `after-load-alist'.
 355 FILE should be the name of a library, with no directory name."
 356   (or (assoc file after-load-alist)
 357       (setq after-load-alist (cons (list file) after-load-alist)))
 358   (nconc (assoc file after-load-alist) (list form))
 359   form)
 360
 361 (defun eval-next-after-load (file)
 362   "Read the following input sexp, and run it whenever FILE is loaded.
 363 This makes or adds to an entry on `after-load-alist'.
 364 FILE should be the name of a library, with no directory name."
 365   (eval-after-load file (read)))
 366
 367 ;;(defmacro defun-inline (name args &rest body)
 368 ;;  "Create an \"inline defun\" (actually a macro).
 369 ;;Use just like `defun'."
 370 ;;  (nconc (list 'defmacro name '(&rest args))
 371 ;;       (if (stringp (car body))
 372 ;;           (prog1 (list (car body))
 373 ;;             (setq body (or (cdr body) body))))
 374 ;;       (list (list 'cons (list 'quote
 375 ;;                               (cons 'lambda (cons args body)))
 376 ;;                   'args))))
 377 \f
 378 (defun user-original-login-name ()
 379   "Return user's login name from original login.
 380 This tries to remain unaffected by `su', by looking in environment variables."
 381   (or (getenv "LOGNAME") (getenv "USER") (user-login-name)))
 382 \f
 383 (defun force-mode-line-update (&optional all)
 384   "Force the mode-line of the current buffer to be redisplayed.
 385 With optional non-nil ALL then force then force redisplay of all mode-lines."
 386   (if all (save-excursion (set-buffer (other-buffer))))
 387   (set-buffer-modified-p (buffer-modified-p)))
 388
 389 (defun keyboard-translate (from to)
 390   "Translate character FROM to TO at a low level.
 391 This function creates a `keyboard-translate-table' if necessary
 392 and then modifies one entry in it."
 393   (or (arrayp keyboard-translate-table)
 394       (setq keyboard-translate-table ""))
 395   (if (or (> from (length keyboard-translate-table))
 396           (> to   (length keyboard-translate-table)))
 397       (progn
 398         (let* ((i (length keyboard-translate-table))
 399                (table (make-string (- 256 i) 0)))
 400           (while (< i 256)
 401             (aset table i i)
 402             (setq i (1+ i)))
 403           (setq keyboard-translate-table table))))
 404   (aset keyboard-translate-table from to))
 405
 406 \f
 407 (defmacro lambda (&rest cdr)
 408   "Return a lambda expression.
 409 A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
 410 self-quoting; the result of evaluating the lambda expression is the
 411 expression itself.  The lambda expression may then be treated as a
 412 function, i. e. stored as the function value of a symbol, passed to
 413 funcall or mapcar, etcetera.
 414 ARGS should take the same form as an argument list for a `defun'.
 415 DOCSTRING should be a string, as described for `defun'.  It may be omitted.
 416 INTERACTIVE should be a call to the function `interactive', which see.
 417 It may also be omitted.
 418 BODY should be a list of lisp expressions."
 419   ;; Note that this definition should not use backquotes; subr.el should not
 420   ;; depend on backquote.el.
 421   (list 'function (cons 'lambda cdr)))
 422
 423 ;;; subr.el ends here