lisp/cmdloop.el

   1 ;;; cmdloop.el --- support functions for the top-level command loop.
   2
   3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Richard Mlynarik
   6 ;; Date: 8-Jul-92
   7 ;; Maintainer: XEmacs Development Team
   8 ;; Keywords: internal, dumped
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.)
  28
  29 ;;; Commentary:
  30
  31 ;; This file is dumped with XEmacs.
  32
  33 ;;; Code:
  34
  35 (defun recursion-depth ()
  36   "Return the current depth in recursive edits."
  37   (+ command-loop-level (minibuffer-depth)))
  38
  39 (defun top-level ()
  40   "Exit all recursive editing levels."
  41   (interactive)
  42   (throw 'top-level nil))
  43
  44 (defun exit-recursive-edit ()
  45   "Exit from the innermost recursive edit or minibuffer."
  46   (interactive)
  47   (if (> (recursion-depth) 0)
  48       (throw 'exit nil))
  49   (error "No recursive edit is in progress"))
  50
  51 (defun abort-recursive-edit ()
  52   "Abort the command that requested this recursive edit or minibuffer input."
  53   (interactive)
  54   (if (> (recursion-depth) 0)
  55       (throw 'exit t))
  56   (error "No recursive edit is in progress"))
  57
  58 ;; (defun keyboard-quit ()
  59 ;;   "Signal a `quit' condition."
  60 ;;   (interactive)
  61 ;;  (deactivate-mark)
  62 ;;   (signal 'quit nil))
  63
  64 ;; moved here from pending-del.
  65 (defun keyboard-quit ()
  66   "Signal a `quit' condition.
  67 If this character is typed while lisp code is executing, it will be treated
  68  as an interrupt.
  69 If this character is typed at top-level, this simply beeps.
  70 If `zmacs-regions' is true, and the zmacs region is active in this buffer,
  71 then this key deactivates the region without beeping or signalling."
  72   (interactive)
  73   (if (region-active-p)
  74       ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
  75       ;; deactivating the region.  If it is inactive, beep.
  76       nil
  77     (signal 'quit nil)))
  78
  79 (defvar buffer-quit-function nil
  80   "Function to call to \"quit\" the current buffer, or nil if none.
  81 \\[keyboard-escape-quit] calls this function when its more local actions
  82 \(such as cancelling a prefix argument, minibuffer or region) do not apply.")
  83
  84 (defun keyboard-escape-quit ()
  85   "Exit the current \"mode\" (in a generalized sense of the word).
  86 This command can exit an interactive command such as `query-replace',
  87 can clear out a prefix argument or a region,
  88 can get out of the minibuffer or other recursive edit,
  89 cancel the use of the current buffer (for special-purpose buffers),
  90 or go back to just one window (by deleting all but the selected window)."
  91   (interactive)
  92   (cond ((eq last-command 'mode-exited) nil)
  93         ((> (minibuffer-depth) 0)
  94          (abort-recursive-edit))
  95         (current-prefix-arg
  96          nil)
  97         ((region-active-p)
  98          (zmacs-deactivate-region))
  99         ((> (recursion-depth) 0)
 100          (exit-recursive-edit))
 101         (buffer-quit-function
 102          (funcall buffer-quit-function))
 103         ((not (one-window-p t))
 104          (delete-other-windows))
 105         ((string-match "^ \\*" (buffer-name (current-buffer)))
 106          (bury-buffer))))
 107
 108 ;; `cancel-mode-internal' is a function of a misc-user event, which is
 109 ;; queued when window system directs XEmacs frame to cancel any modal
 110 ;; behavior it exposes, like mouse pointer grabbing.
 111 ;;
 112 ;; This function does nothing at the top level, but the code which
 113 ;; runs modal event loops, such as selection drag loop in `mouse-track',
 114 ;; check if misc-user function symbol is `cancel-mode-internal', and
 115 ;; takes necessary cleanup actions.
 116 (defun cancel-mode-internal (object)
 117   (setq zmacs-region-stays t))
 118 \f
 119 ;; Someone wrote: "This should really be a ring of last errors."
 120 ;;
 121 ;; But why bother?  This stuff is not all that necessary now that we
 122 ;; have message log, anyway.
 123 (defvar last-error nil
 124   "Object describing the last signaled error.")
 125
 126 (defcustom errors-deactivate-region nil
 127   "*Non-nil means that errors will cause the region to be deactivated."
 128   :type 'boolean
 129   :group 'editing-basics)
 130
 131 (defun command-error (error-object)
 132   (let* ((old-debug-on-error debug-on-error)
 133          (inhibit-quit t)
 134          (debug-on-error nil)
 135          (etype (car-safe error-object)))
 136     (setq quit-flag nil)
 137     (setq standard-output t)
 138     (setq standard-input t)
 139     (setq executing-kbd-macro nil)
 140     (and errors-deactivate-region
 141          (zmacs-deactivate-region))
 142     (discard-input)
 143
 144     (setq last-error error-object)
 145
 146     (message nil)
 147     (ding nil (cond ((eq etype 'undefined-keystroke-sequence)
 148                      (if (and (vectorp (nth 1 error-object))
 149                               (/= 0 (length (nth 1 error-object)))
 150                               (button-event-p (aref (nth 1 error-object) 0)))
 151                          'undefined-click
 152                        'undefined-key))
 153                     ((eq etype 'quit)
 154                      'quit)
 155                     ((memq etype '(end-of-buffer beginning-of-buffer))
 156                      'buffer-bound)
 157                     ((eq etype 'buffer-read-only)
 158                      'read-only)
 159                     (t 'command-error)))
 160     (display-error error-object t)
 161
 162     (if (noninteractive)
 163         (progn
 164           (if old-debug-on-error
 165               (progn
 166                 (message "Backtrace:\n\n")
 167                 (backtrace)
 168                 (message "\n")))
 169           (message "%s exiting\n." emacs-program-name)
 170           (kill-emacs -1)))
 171     t))
 172
 173 (defun describe-last-error ()
 174   "Redisplay the last error-message.  See the variable `last-error'."
 175   (interactive)
 176   (if last-error
 177       (with-displaying-help-buffer
 178        (lambda ()
 179          (princ "Last error was:\n" standard-output)
 180          (display-error last-error standard-output)))
 181     (message "No error yet")))
 182
 183
 184 ;;#### Must be done later in the loadup sequence
 185 ;(define-key (symbol-function 'help-command) "e" 'describe-last-error)
 186
 187
 188 (defun truncate-command-history-for-gc ()
 189   ;; We should try to avoid accessing any bindings to speak of in this
 190   ;; function; as this hook is called asynchronously, the search for
 191   ;; those bindings might search local bindings from essentially
 192   ;; arbitrary functions. We force the body of the function to run at
 193   ;; command-loop level, where the danger of local bindings is much
 194   ;; reduced; the code can still do its job because the command history
 195   ;; and values list will not grow before then anyway.
 196   ;;
 197   ;; Nothing is done in batch mode, both because it is a waste of time
 198   ;; (there is no command loop!) and because this any GCs during dumping
 199   ;; will invoke this code, and if it were to enqueue an eval event,
 200   ;; the portable dumper would try to dump it and fail.
 201   (if (not (noninteractive))
 202       (enqueue-eval-event
 203        #'(lambda (arg)
 204            (let ((tail (nthcdr 30 command-history)))
 205              (if tail (setcdr tail nil)))
 206            (let ((tail (nthcdr 30 values)))
 207              (if tail (setcdr tail nil))))
 208        nil)))
 209
 210 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
 211
 212 \f
 213 ;;;; Object-oriented programming at its finest
 214
 215 ;; Now in src/print.c; used by Ferror_message_string and others
 216 ;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
 217 ;  "Display `error-object' on `stream' in a user-friendly way."
 218 ;  (funcall (or (let ((type (car-safe error-object)))
 219 ;                 (catch 'error
 220 ;                   (and (consp error-object)
 221 ;                        (symbolp type)
 222 ;                        ;;(stringp (get type 'error-message))
 223 ;                       (consp (get type 'error-conditions))
 224 ;                        (let ((tail (cdr error-object)))
 225 ;                          (while (not (null tail))
 226 ;                            (if (consp tail)
 227 ;                                (setq tail (cdr tail))
 228 ;                                (throw 'error nil)))
 229 ;                          t)
 230 ;                        ;; (check-type condition condition)
 231 ;                        (get type 'error-conditions)
 232 ;                        ;; Search class hierarchy
 233 ;                        (let ((tail (get type 'error-conditions)))
 234 ;                          (while (not (null tail))
 235 ;                            (cond ((not (and (consp tail)
 236 ;                                             (symbolp (car tail))))
 237 ;                                   (throw 'error nil))
 238 ;                                  ((get (car tail) 'display-error)
 239 ;                                   (throw 'error (get (car tail)
 240 ;                                                      'display-error)))
 241 ;                                  (t
 242 ;                                   (setq tail (cdr tail)))))
 243 ;                          ;; Default method
 244 ;                          #'(lambda (error-object stream)
 245 ;                              (let ((type (car error-object))
 246 ;                                    (tail (cdr error-object))
 247 ;                                    (first t)
 248 ;                                   (print-message-label 'error))
 249 ;                                (if (eq type 'error)
 250 ;                                    (progn (princ (car tail) stream)
 251 ;                                           (setq tail (cdr tail)))
 252 ;                                 (princ (or (gettext (get type 'error-message)) type)
 253 ;                                        stream))
 254 ;                                (while tail
 255 ;                                  (princ (if first ": " ", ") stream)
 256 ;                                  (prin1 (car tail) stream)
 257 ;                                  (setq tail (cdr tail)
 258 ;                                        first nil))))))))
 259 ;              #'(lambda (error-object stream)
 260 ;                   (princ (gettext "Peculiar error ") stream)
 261 ;                   (prin1 error-object stream)))
 262 ;           error-object stream))
 263
 264 (put 'file-error 'display-error
 265      #'(lambda (error-object stream)
 266          (let ((tail (cdr error-object))
 267                (first t))
 268            (princ (car tail) stream)
 269            (while (setq tail (cdr tail))
 270              (princ (if first ": " ", ") stream)
 271              (princ (car tail) stream)
 272              (setq first nil)))))
 273
 274 (put 'undefined-keystroke-sequence 'display-error
 275      #'(lambda (error-object stream)
 276          (princ (key-description (car (cdr error-object))) stream)
 277          ;; #### I18N3: doesn't localize properly.
 278          (princ (gettext " not defined.") stream) ; doo dah, doo dah.
 279          ))
 280
 281 \f
 282 (defcustom teach-extended-commands-p t
 283   "*If true, then `\\[execute-extended-command]' will teach you keybindings.
 284 Any time you execute a command with \\[execute-extended-command] which has a
 285 shorter keybinding, you will be shown the alternate binding before the
 286 command executes.  There is a short pause after displaying the binding,
 287 before executing it; the length can be controlled by
 288 `teach-extended-commands-timeout'."
 289   :type 'boolean
 290   :group 'keyboard)
 291
 292 (defcustom teach-extended-commands-timeout 4
 293   "*How long to pause after displaying a keybinding before executing.
 294 The value is measured in seconds.  This only applies if
 295 `teach-extended-commands-p' is true."
 296   :type 'number
 297   :group 'keyboard)
 298
 299 ;That damn RMS went off and implemented something differently, after
 300 ;we had already implemented it.  We can't support both properly until
 301 ;we have Lisp magic variables.
 302 ;(defvar suggest-key-bindings t
 303 ;  "*FSFmacs equivalent of `teach-extended-commands-*'.
 304 ;Provided for compatibility only.
 305 ;Non-nil means show the equivalent key-binding when M-x command has one.
 306 ;The value can be a length of time to show the message for.
 307 ;If the value is non-nil and not a number, we wait 2 seconds.")
 308 ;
 309 ;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p)
 310
 311 (defun execute-extended-command (prefix-arg)
 312   "Read a command name from the minibuffer using 'completing-read'.
 313 Then call the specified command using 'command-execute' and return its
 314 return value.  If the command asks for a prefix argument, supply the
 315 value of the current raw prefix argument, or the value of PREFIX-ARG
 316 when called from Lisp."
 317   (interactive "P")
 318   ;; Note:  This doesn't hack "this-command-keys"
 319   (let ((prefix-arg prefix-arg))
 320     (setq this-command (read-command
 321                         ;; Note: this has the hard-wired
 322                         ;;  "C-u" and "M-x" string bug in common
 323                         ;;  with all GNU Emacs's.
 324                         ;; (i.e. it prints C-u and M-x regardless of
 325                         ;; whether some other keys were actually bound
 326                         ;; to `execute-extended-command' and
 327                         ;; `universal-argument'.
 328                         (cond ((eq prefix-arg '-)
 329                                "- M-x ")
 330                               ((equal prefix-arg '(4))
 331                                "C-u M-x ")
 332                               ((integerp prefix-arg)
 333                                (format "%d M-x " prefix-arg))
 334                               ((and (consp prefix-arg)
 335                                     (integerp (car prefix-arg)))
 336                                (format "%d M-x " (car prefix-arg)))
 337                               (t
 338                                "M-x ")))))
 339
 340   (if (and teach-extended-commands-p
 341            (interactive-p))
 342       ;; Remember the keys, run the command, and show the keys (if
 343       ;; any).  The funny variable names are a poor man's guarantee
 344       ;; that we don't get tripped by this-command doing something
 345       ;; funny.  Quoth our forefathers: "We want lexical scope!"
 346       (let ((_execute_command_keys_ (where-is-internal this-command))
 347             (_execute_command_name_ this-command)) ; the name can change
 348         (command-execute this-command t)
 349         (when _execute_command_keys_
 350           ;; Normally the region is adjusted in post_command_hook;
 351           ;; however, it is not called until after we finish.  It
 352           ;; looks ugly for the region to get updated after the
 353           ;; delays, so we do it now.  The code below is a Lispified
 354           ;; copy of code in event-stream.c:post_command_hook().
 355           (if (and (not zmacs-region-stays)
 356                    (or (not (eq (selected-window) (minibuffer-window)))
 357                        (eq (zmacs-region-buffer) (current-buffer))))
 358               (zmacs-deactivate-region)
 359             (zmacs-update-region))
 360           ;; Wait for a while, so the user can see a message printed,
 361           ;; if any.
 362           (when (sit-for 1)
 363             (display-message
 364                 'no-log
 365               (format (if (cdr _execute_command_keys_)
 366                           "Command `%s' is bound to keys: %s"
 367                         "Command `%s' is bound to key: %s")
 368                       _execute_command_name_
 369                       (sorted-key-descriptions _execute_command_keys_)))
 370             (sit-for teach-extended-commands-timeout)
 371             (clear-message 'no-log))))
 372     ;; Else, just run the command.
 373     (command-execute this-command t)))
 374
 375
 376 ;;; C code calls this; the underscores in the variable names are to avoid
 377 ;;; cluttering the specbind namespace (lexical scope!  lexical scope!)
 378 ;;; Putting this in Lisp instead of C slows kbd macros by 50%.
 379 ;(defun command-execute (_command &optional _record-flag)
 380 ;  "Execute CMD as an editor command.
 381 ;CMD must be a symbol that satisfies the `commandp' predicate.
 382 ;Optional second arg RECORD-FLAG non-nil
 383 ;means unconditionally put this command in `command-history'.
 384 ;Otherwise, that is done only if an arg is read using the minibuffer."
 385 ;  (let ((_prefix prefix-arg)
 386 ;        (_cmd (indirect-function _command)))
 387 ;    (setq prefix-arg nil
 388 ;          this-command _command
 389 ;          current-prefix-arg _prefix
 390 ;          zmacs-region-stays nil)
 391 ;    ;; #### debug_on_next_call = 0;
 392 ;    (cond ((and (symbolp _command)
 393 ;                (get _command 'disabled))
 394 ;           (run-hooks disabled-command-hook))
 395 ;          ((or (stringp _cmd) (vectorp _cmd))
 396 ;           ;; If requested, place the macro in the command history.
 397 ;           ;;  For other sorts of commands, call-interactively takes
 398 ;           ;;  care of this.
 399 ;           (if _record-flag
 400 ;               (setq command-history
 401 ;                     (cons (list 'execute-kbd-macro _cmd _prefix)
 402 ;                           command-history)))
 403 ;             (execute-kbd-macro _cmd _prefix))
 404 ;            (t
 405 ;             (call-interactively _command _record-flag)))))
 406 \f
 407 (defun y-or-n-p-minibuf (prompt)
 408   "Ask user a \"y or n\" question.  Return t if answer is \"y\", nil if \"n\".
 409 Takes one argument, which is the string to display to ask the question.
 410 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
 411 No confirmation of the answer is requested; a single character is enough.
 412 Also accepts Space to mean yes, or Delete to mean no."
 413   (save-excursion
 414     (let* ((pre "")
 415            (yn (gettext "(y or n) "))
 416            ;; we need to translate the prompt ourselves because of the
 417            ;; strange way we handle it.
 418            (prompt (gettext prompt))
 419            event)
 420       (while (stringp yn)
 421         (if (let ((cursor-in-echo-area t)
 422                   (inhibit-quit t))
 423               (message "%s%s%s" pre prompt yn)
 424               (setq event (next-command-event event))
 425               (condition-case nil
 426                   (prog1
 427                       (or quit-flag (eq 'keyboard-quit (key-binding event)))
 428                     (setq quit-flag nil))
 429                 (wrong-type-argument t)))
 430             (progn
 431               (message "%s%s%s%s" pre prompt yn (single-key-description event))
 432               (setq quit-flag nil)
 433               (signal 'quit '())))
 434         (let* ((keys (events-to-keys (vector event)))
 435                (def (lookup-key query-replace-map keys)))
 436           (cond ((eq def 'skip)
 437                  (message "%s%sNo" prompt yn)
 438                  (setq yn nil))
 439                 ((eq def 'act)
 440                  (message "%s%sYes" prompt yn)
 441                  (setq yn t))
 442                 ((eq def 'recenter)
 443                  (recenter))
 444                 ((or (eq def 'quit) (eq def 'exit-prefix))
 445                  (signal 'quit '()))
 446                 ((button-release-event-p event) ; ignore them
 447                  nil)
 448                 (t
 449                  (message "%s%s%s%s" pre prompt yn
 450                           (single-key-description event))
 451                  (ding nil 'y-or-n-p)
 452                  (discard-input)
 453                  (if (= (length pre) 0)
 454                      (setq pre (gettext "Please answer y or n.  ")))))))
 455       yn)))
 456
 457 (defun yes-or-no-p-minibuf (prompt)
 458   "Ask user a yes-or-no question.  Return t if answer is yes.
 459 Takes one argument, which is the string to display to ask the question.
 460 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
 461 The user must confirm the answer with RET,
 462 and can edit it until it has been confirmed."
 463   (save-excursion
 464     (let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
 465           (ans ""))
 466       (while (stringp ans)
 467         (setq ans (downcase (read-string p nil t))) ;no history
 468         (cond ((string-equal ans (gettext "yes"))
 469                (setq ans t))
 470               ((string-equal ans (gettext "no"))
 471                (setq ans nil))
 472               (t
 473                (ding nil 'yes-or-no-p)
 474                (discard-input)
 475                (message "Please answer yes or no.")
 476                (sleep-for 2))))
 477       ans)))
 478
 479 (defun yes-or-no-p (prompt)
 480   "Ask user a yes-or-no question.  Return t if answer is yes.
 481 The question is asked with a dialog box or the minibuffer, as appropriate.
 482 Takes one argument, which is the string to display to ask the question.
 483 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
 484 The user must confirm the answer with RET,
 485 and can edit it until it as been confirmed."
 486   (if (should-use-dialog-box-p)
 487       (yes-or-no-p-dialog-box prompt)
 488     (yes-or-no-p-minibuf prompt)))
 489
 490 (defun y-or-n-p (prompt)
 491   "Ask user a \"y or n\" question.  Return t if answer is \"y\", nil if \"n\".
 492 Takes one argument, which is the string to display to ask the question.
 493 The question is asked with a dialog box or the minibuffer, as appropriate.
 494 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
 495 No confirmation of the answer is requested; a single character is enough.
 496 Also accepts Space to mean yes, or Delete to mean no."
 497   (if (should-use-dialog-box-p)
 498       (yes-or-no-p-dialog-box prompt)
 499     (y-or-n-p-minibuf prompt)))
 500
 501 \f
 502
 503 (defun read-char ()
 504   "Read a character from the command input (keyboard or macro).
 505 If a mouse click or non-ASCII character is detected, an error is
 506 signalled.  The character typed is returned as an ASCII value.  This
 507 is most likely the wrong thing for you to be using: consider using
 508 the `next-command-event' function instead."
 509   (save-excursion
 510     (let ((event (next-command-event)))
 511       (or inhibit-quit
 512           (and (event-matches-key-specifier-p event (quit-char))
 513                (signal 'quit nil)))
 514       (prog1 (or (event-to-character event)
 515                  ;; Kludge.  If the event we read was a mouse-release,
 516                  ;; discard it and read the next one.
 517                  (if (button-release-event-p event)
 518                      (event-to-character (next-command-event event)))
 519                  (error "Key read has no ASCII equivalent %S" event))
 520         ;; this is not necessary, but is marginally more efficient than GC.
 521         (deallocate-event event)))))
 522
 523 (defun read-char-exclusive ()
 524   "Read a character from the command input (keyboard or macro).
 525 If a mouse click or non-ASCII character is detected, it is discarded.
 526 The character typed is returned as an ASCII value.  This is most likely
 527 the wrong thing for you to be using: consider using the
 528 `next-command-event' function instead."
 529   (let (event ch)
 530     (while (progn
 531              (setq event (next-command-event))
 532              (or inhibit-quit
 533                  (and (event-matches-key-specifier-p event (quit-char))
 534                       (signal 'quit nil)))
 535              (setq ch (event-to-character event))
 536              (deallocate-event event)
 537              (null ch)))
 538     ch))
 539
 540 (defun read-quoted-char (&optional prompt)
 541   "Like `read-char', except that if the first character read is an octal
 542 digit, we read up to two more octal digits and return the character
 543 represented by the octal number consisting of those digits.
 544 Optional argument PROMPT specifies a string to use to prompt the user."
 545   (let ((count 0) (code 0) done
 546         (prompt (and prompt (gettext prompt)))
 547         char event)
 548     (while (and (not done) (< count 3))
 549       (let ((inhibit-quit (zerop count))
 550             ;; Don't let C-h get the help message--only help function keys.
 551             (help-char nil)
 552             (help-form
 553              "Type the special character you want to use,
 554 or three octal digits representing its character code."))
 555         (and prompt (display-message 'prompt (format "%s-" prompt)))
 556         (setq event (next-command-event)
 557               char (or (event-to-character event nil nil t)
 558                        (signal 'error
 559                                (list "key read cannot be inserted in a buffer"
 560                                      event))))
 561         (if inhibit-quit (setq quit-flag nil)))
 562       (cond ((<= ?0 char ?7)
 563              (setq code (+ (* code 8) (- char ?0))
 564                    count (1+ count))
 565              (when prompt
 566                (display-message 'prompt
 567                  (setq prompt (format "%s %c" prompt char)))))
 568             ((> count 0)
 569              (setq unread-command-event event
 570                    done t))
 571             (t (setq code (char-int char)
 572                      done t))))
 573     (int-char code)
 574     ;; Turn a meta-character into a character with the 0200 bit set.
 575 ;    (logior (if (/= (logand code ?\M-\^@) 0) 128 0)
 576 ;           (logand 255 code))))
 577     ))
 578
 579 (defun momentary-string-display (string pos &optional exit-char message)
 580   "Momentarily display STRING in the buffer at POS.
 581 Display remains until next character is typed.
 582 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
 583 otherwise it is then available as input (as a command if nothing else).
 584 Display MESSAGE (optional fourth arg) in the echo area.
 585 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
 586   (or exit-char (setq exit-char ?\ ))
 587   (let ((buffer-read-only nil)
 588         ;; Don't modify the undo list at all.
 589         (buffer-undo-list t)
 590         (modified (buffer-modified-p))
 591         (name buffer-file-name)
 592         insert-end)
 593     (unwind-protect
 594         (progn
 595           (save-excursion
 596             (goto-char pos)
 597             ;; defeat file locking... don't try this at home, kids!
 598             (setq buffer-file-name nil)
 599             (insert-before-markers (gettext string))
 600             (setq insert-end (point))
 601             ;; If the message end is off frame, recenter now.
 602             (if (> (window-end) insert-end)
 603                 (recenter (/ (window-height) 2)))
 604             ;; If that pushed message start off the frame,
 605             ;; scroll to start it at the top of the frame.
 606             (move-to-window-line 0)
 607             (if (> (point) pos)
 608                 (progn
 609                   (goto-char pos)
 610                   (recenter 0))))
 611           (message (or message (gettext "Type %s to continue editing."))
 612                    (single-key-description exit-char))
 613           (let ((event (save-excursion (next-command-event))))
 614             (or (eq (event-to-character event) exit-char)
 615                 (setq unread-command-event event))))
 616       (if insert-end
 617           (save-excursion
 618             (delete-region pos insert-end)))
 619       (setq buffer-file-name name)
 620       (set-buffer-modified-p modified))))
 621
 622 ;;; cmdloop.el ends here