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