1 ;;; cmdloop.el --- support functions for the top-level command loop.
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
5 ;; Author: Richard Mlynarik
7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: internal, dumped
10 ;; This file is part of XEmacs.
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)
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.
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.
27 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.)
31 ;; This file is dumped with XEmacs.
35 (defun recursion-depth ()
36 "Return the current depth in recursive edits."
37 (+ command-loop-level (minibuffer-depth)))
40 "Exit all recursive editing levels."
42 (throw 'top-level nil))
44 (defun exit-recursive-edit ()
45 "Exit from the innermost recursive edit or minibuffer."
47 (if (> (recursion-depth) 0)
49 (error "No recursive edit is in progress"))
51 (defun abort-recursive-edit ()
52 "Abort the command that requested this recursive edit or minibuffer input."
54 (if (> (recursion-depth) 0)
56 (error "No recursive edit is in progress"))
58 ;; (defun keyboard-quit ()
59 ;; "Signal a `quit' condition."
62 ;; (signal 'quit nil))
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
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."
73 (if (and (region-active-p)
74 (eq (current-buffer) (zmacs-region-buffer)))
75 ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
76 ;; deactivating the region. If it is inactive, beep.
80 (defvar buffer-quit-function nil
81 "Function to call to \"quit\" the current buffer, or nil if none.
82 \\[keyboard-escape-quit] calls this function when its more local actions
83 \(such as cancelling a prefix argument, minibuffer or region) do not apply.")
85 (defun keyboard-escape-quit ()
86 "Exit the current \"mode\" (in a generalized sense of the word).
87 This command can exit an interactive command such as `query-replace',
88 can clear out a prefix argument or a region,
89 can get out of the minibuffer or other recursive edit,
90 cancel the use of the current buffer (for special-purpose buffers),
91 or go back to just one window (by deleting all but the selected window)."
93 (cond ((eq last-command 'mode-exited) nil)
94 ((> (minibuffer-depth) 0)
95 (abort-recursive-edit))
99 (zmacs-deactivate-region))
100 ((> (recursion-depth) 0)
101 (exit-recursive-edit))
102 (buffer-quit-function
103 (funcall buffer-quit-function))
104 ((not (one-window-p t))
105 (delete-other-windows))
106 ((string-match "^ \\*" (buffer-name (current-buffer)))
109 ;; `cancel-mode-internal' is a function of a misc-user event, which is
110 ;; queued when window system directs XEmacs frame to cancel any modal
111 ;; behavior it exposes, like mouse pointer grabbing.
113 ;; This function does nothing at the top level, but the code which
114 ;; runs modal event loops, such as selection drag loop in `mouse-track',
115 ;; check if misc-user function symbol is `cancel-mode-internal', and
116 ;; takes necessary cleanup actions.
117 (defun cancel-mode-internal (object)
118 (setq zmacs-region-stays t))
120 ;; Someone wrote: "This should really be a ring of last errors."
122 ;; But why bother? This stuff is not all that necessary now that we
123 ;; have message log, anyway.
124 (defvar last-error nil
125 "Object describing the last signaled error.")
127 (defcustom errors-deactivate-region nil
128 "*Non-nil means that errors will cause the region to be deactivated."
130 :group 'editing-basics)
132 (defun command-error (error-object)
133 (let ((inhibit-quit t)
135 (etype (car-safe error-object)))
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))
144 (setq last-error error-object)
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)))
155 ((memq etype '(end-of-buffer beginning-of-buffer))
157 ((eq etype 'buffer-read-only)
160 (display-error error-object t)
164 (message "%s exiting." emacs-program-name)
168 (defun describe-last-error ()
169 "Redisplay the last error-message. See the variable `last-error'."
172 (with-displaying-help-buffer
174 (princ "Last error was:\n" standard-output)
175 (display-error last-error standard-output)))
176 (message "No error yet")))
179 ;;#### Must be done later in the loadup sequence
180 ;(define-key (symbol-function 'help-command) "e" 'describe-last-error)
183 (defun truncate-command-history-for-gc ()
184 (let ((tail (nthcdr 30 command-history)))
185 (if tail (setcdr tail nil)))
186 (let ((tail (nthcdr 30 values)))
187 (if tail (setcdr tail nil)))
190 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
193 ;;;; Object-oriented programming at its finest
195 ;; Now in src/print.c; used by Ferror_message_string and others
196 ;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
197 ; "Display `error-object' on `stream' in a user-friendly way."
198 ; (funcall (or (let ((type (car-safe error-object)))
200 ; (and (consp error-object)
202 ; ;;(stringp (get type 'error-message))
203 ; (consp (get type 'error-conditions))
204 ; (let ((tail (cdr error-object)))
205 ; (while (not (null tail))
207 ; (setq tail (cdr tail))
208 ; (throw 'error nil)))
210 ; ;; (check-type condition condition)
211 ; (get type 'error-conditions)
212 ; ;; Search class hierarchy
213 ; (let ((tail (get type 'error-conditions)))
214 ; (while (not (null tail))
215 ; (cond ((not (and (consp tail)
216 ; (symbolp (car tail))))
217 ; (throw 'error nil))
218 ; ((get (car tail) 'display-error)
219 ; (throw 'error (get (car tail)
222 ; (setq tail (cdr tail)))))
224 ; #'(lambda (error-object stream)
225 ; (let ((type (car error-object))
226 ; (tail (cdr error-object))
228 ; (print-message-label 'error))
229 ; (if (eq type 'error)
230 ; (progn (princ (car tail) stream)
231 ; (setq tail (cdr tail)))
232 ; (princ (or (gettext (get type 'error-message)) type)
235 ; (princ (if first ": " ", ") stream)
236 ; (prin1 (car tail) stream)
237 ; (setq tail (cdr tail)
239 ; #'(lambda (error-object stream)
240 ; (princ (gettext "Peculiar error ") stream)
241 ; (prin1 error-object stream)))
242 ; error-object stream))
244 (put 'file-error 'display-error
245 #'(lambda (error-object stream)
246 (let ((tail (cdr error-object))
248 (princ (car tail) stream)
249 (while (setq tail (cdr tail))
250 (princ (if first ": " ", ") stream)
251 (princ (car tail) stream)
254 (put 'undefined-keystroke-sequence 'display-error
255 #'(lambda (error-object stream)
256 (princ (key-description (car (cdr error-object))) stream)
257 ;; #### I18N3: doesn't localize properly.
258 (princ (gettext " not defined.") stream) ; doo dah, doo dah.
262 (defcustom teach-extended-commands-p t
263 "*If true, then `\\[execute-extended-command]' will teach you keybindings.
264 Any time you execute a command with \\[execute-extended-command] which has a
265 shorter keybinding, you will be shown the alternate binding before the
266 command executes. There is a short pause after displaying the binding,
267 before executing it; the length can be controlled by
268 `teach-extended-commands-timeout'."
272 (defcustom teach-extended-commands-timeout 4
273 "*How long to pause after displaying a keybinding before executing.
274 The value is measured in seconds. This only applies if
275 `teach-extended-commands-p' is true."
279 ;That damn RMS went off and implemented something differently, after
280 ;we had already implemented it. We can't support both properly until
281 ;we have Lisp magic variables.
282 ;(defvar suggest-key-bindings t
283 ; "*FSFmacs equivalent of `teach-extended-commands-*'.
284 ;Provided for compatibility only.
285 ;Non-nil means show the equivalent key-binding when M-x command has one.
286 ;The value can be a length of time to show the message for.
287 ;If the value is non-nil and not a number, we wait 2 seconds.")
289 ;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p)
291 (defun execute-extended-command (prefix-arg)
292 "Read a command name from the minibuffer using 'completing-read'.
293 Then call the specified command using 'command-execute' and return its
294 return value. If the command asks for a prefix argument, supply the
295 value of the current raw prefix argument, or the value of PREFIX-ARG
296 when called from Lisp."
298 ;; Note: This doesn't hack "this-command-keys"
299 (let ((prefix-arg prefix-arg))
300 (setq this-command (read-command
301 ;; Note: this has the hard-wired
302 ;; "C-u" and "M-x" string bug in common
303 ;; with all GNU Emacs's.
304 ;; (i.e. it prints C-u and M-x regardless of
305 ;; whether some other keys were actually bound
306 ;; to `execute-extended-command' and
307 ;; `universal-argument'.
308 (cond ((eq prefix-arg '-)
310 ((equal prefix-arg '(4))
312 ((integerp prefix-arg)
313 (format "%d M-x " prefix-arg))
314 ((and (consp prefix-arg)
315 (integerp (car prefix-arg)))
316 (format "%d M-x " (car prefix-arg)))
320 (if (and teach-extended-commands-p
322 ;; We need to fiddle with keys: remember the keys, run the
323 ;; command, and show the keys (if any).
324 (let ((_execute_command_keys_ (where-is-internal this-command))
325 (_execute_command_name_ this-command)) ; the name can change
326 (command-execute this-command t)
327 (when (and _execute_command_keys_
328 ;; Wait for a while, so the user can see a message
333 (format "Command `%s' is bound to key%s: %s"
334 _execute_command_name_
335 (if (cdr _execute_command_keys_) "s" "")
336 (sorted-key-descriptions _execute_command_keys_)))
337 (sit-for teach-extended-commands-timeout)
338 (clear-message 'no-log)))
339 ;; Else, just run the command.
340 (command-execute this-command t)))
343 ;;; C code calls this; the underscores in the variable names are to avoid
344 ;;; cluttering the specbind namespace (lexical scope! lexical scope!)
345 ;;; Putting this in Lisp instead of C slows kbd macros by 50%.
346 ;(defun command-execute (_command &optional _record-flag)
347 ; "Execute CMD as an editor command.
348 ;CMD must be a symbol that satisfies the `commandp' predicate.
349 ;Optional second arg RECORD-FLAG non-nil
350 ;means unconditionally put this command in `command-history'.
351 ;Otherwise, that is done only if an arg is read using the minibuffer."
352 ; (let ((_prefix prefix-arg)
353 ; (_cmd (indirect-function _command)))
354 ; (setq prefix-arg nil
355 ; this-command _command
356 ; current-prefix-arg _prefix
357 ; zmacs-region-stays nil)
358 ; ;; #### debug_on_next_call = 0;
359 ; (cond ((and (symbolp _command)
360 ; (get _command 'disabled))
361 ; (run-hooks disabled-command-hook))
362 ; ((or (stringp _cmd) (vectorp _cmd))
363 ; ;; If requested, place the macro in the command history.
364 ; ;; For other sorts of commands, call-interactively takes
367 ; (setq command-history
368 ; (cons (list 'execute-kbd-macro _cmd _prefix)
370 ; (execute-kbd-macro _cmd _prefix))
372 ; (call-interactively _command _record-flag)))))
374 (defun y-or-n-p-minibuf (prompt)
375 "Ask user a \"y or n\" question. Return t if answer is \"y\".
376 Takes one argument, which is the string to display to ask the question.
377 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
378 No confirmation of the answer is requested; a single character is enough.
379 Also accepts Space to mean yes, or Delete to mean no."
382 (yn (gettext "(y or n) "))
383 ;; we need to translate the prompt ourselves because of the
384 ;; strange way we handle it.
385 (prompt (gettext prompt))
388 (if (let ((cursor-in-echo-area t)
390 (message "%s%s%s" pre prompt yn)
391 (setq event (next-command-event event))
394 (or quit-flag (eq 'keyboard-quit (key-binding event)))
395 (setq quit-flag nil))
396 (wrong-type-argument t)))
398 (message "%s%s%s%s" pre prompt yn (single-key-description event))
401 (let* ((keys (events-to-keys (vector event)))
402 (def (lookup-key query-replace-map keys)))
403 (cond ((eq def 'skip)
404 (message "%s%sNo" prompt yn)
407 (message "%s%sYes" prompt yn)
411 ((or (eq def 'quit) (eq def 'exit-prefix))
413 ((button-release-event-p event) ; ignore them
416 (message "%s%s%s%s" pre prompt yn
417 (single-key-description event))
420 (if (= (length pre) 0)
421 (setq pre (gettext "Please answer y or n. ")))))))
424 (defun yes-or-no-p-minibuf (prompt)
425 "Ask user a yes-or-no question. Return t if answer is yes.
426 Takes one argument, which is the string to display to ask the question.
427 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
428 The user must confirm the answer with RET,
429 and can edit it until it has been confirmed."
431 (let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
434 (setq ans (downcase (read-string p nil t))) ;no history
435 (cond ((string-equal ans (gettext "yes"))
437 ((string-equal ans (gettext "no"))
440 (ding nil 'yes-or-no-p)
442 (message "Please answer yes or no.")
446 ;; these may be redefined later, but make the original def easily encapsulable
447 (define-function 'yes-or-no-p 'yes-or-no-p-minibuf)
448 (define-function 'y-or-n-p 'y-or-n-p-minibuf)
452 "Read a character from the command input (keyboard or macro).
453 If a mouse click or non-ASCII character is detected, an error is
454 signalled. The character typed is returned as an ASCII value. This
455 is most likely the wrong thing for you to be using: consider using
456 the `next-command-event' function instead."
458 (let ((event (next-command-event)))
460 (and (event-matches-key-specifier-p event (quit-char))
462 (prog1 (or (event-to-character event)
463 ;; Kludge. If the event we read was a mouse-release,
464 ;; discard it and read the next one.
465 (if (button-release-event-p event)
466 (event-to-character (next-command-event event)))
467 (error "Key read has no ASCII equivalent %S" event))
468 ;; this is not necessary, but is marginally more efficient than GC.
469 (deallocate-event event)))))
471 (defun read-char-exclusive ()
472 "Read a character from the command input (keyboard or macro).
473 If a mouse click or non-ASCII character is detected, it is discarded.
474 The character typed is returned as an ASCII value. This is most likely
475 the wrong thing for you to be using: consider using the
476 `next-command-event' function instead."
479 (setq event (next-command-event))
481 (and (event-matches-key-specifier-p event (quit-char))
483 (setq ch (event-to-character event))
484 (deallocate-event event)
488 (defun read-quoted-char (&optional prompt)
489 "Like `read-char', except that if the first character read is an octal
490 digit, we read up to two more octal digits and return the character
491 represented by the octal number consisting of those digits.
492 Optional argument PROMPT specifies a string to use to prompt the user."
493 (let ((count 0) (code 0) done
494 (prompt (and prompt (gettext prompt)))
496 (while (and (not done) (< count 3))
497 (let ((inhibit-quit (zerop count))
498 ;; Don't let C-h get the help message--only help function keys.
501 "Type the special character you want to use,
502 or three octal digits representing its character code."))
503 (and prompt (display-message 'prompt (format "%s-" prompt)))
504 (setq event (next-command-event)
505 char (or (event-to-character event nil nil t)
507 (list "key read cannot be inserted in a buffer"
509 (if inhibit-quit (setq quit-flag nil)))
510 (cond ((<= ?0 char ?7)
511 (setq code (+ (* code 8) (- char ?0))
514 (display-message 'prompt
515 (setq prompt (format "%s %c" prompt char)))))
517 (setq unread-command-event event
519 (t (setq code (char-int char)
522 ;; Turn a meta-character into a character with the 0200 bit set.
523 ; (logior (if (/= (logand code ?\M-\^@) 0) 128 0)
524 ; (logand 255 code))))
527 (defun momentary-string-display (string pos &optional exit-char message)
528 "Momentarily display STRING in the buffer at POS.
529 Display remains until next character is typed.
530 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
531 otherwise it is then available as input (as a command if nothing else).
532 Display MESSAGE (optional fourth arg) in the echo area.
533 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
534 (or exit-char (setq exit-char ?\ ))
535 (let ((buffer-read-only nil)
536 ;; Don't modify the undo list at all.
538 (modified (buffer-modified-p))
539 (name buffer-file-name)
545 ;; defeat file locking... don't try this at home, kids!
546 (setq buffer-file-name nil)
547 (insert-before-markers (gettext string))
548 (setq insert-end (point))
549 ;; If the message end is off frame, recenter now.
550 (if (> (window-end) insert-end)
551 (recenter (/ (window-height) 2)))
552 ;; If that pushed message start off the frame,
553 ;; scroll to start it at the top of the frame.
554 (move-to-window-line 0)
559 (message (or message (gettext "Type %s to continue editing."))
560 (single-key-description exit-char))
561 (let ((event (save-excursion (next-command-event))))
562 (or (eq (event-to-character event) exit-char)
563 (setq unread-command-event event))))
566 (delete-region pos insert-end)))
567 (setq buffer-file-name name)
568 (set-buffer-modified-p modified))))
570 ;;; cmdloop.el ends here