annotate lisp/cmdloop.el @ 665:fdefd0186b75

[xemacs-hg @ 2001-09-20 06:28:42 by ben] The great integral types renaming. The purpose of this is to rationalize the names used for various integral types, so that they match their intended uses and follow consist conventions, and eliminate types that were not semantically different from each other. The conventions are: -- All integral types that measure quantities of anything are signed. Some people disagree vociferously with this, but their arguments are mostly theoretical, and are vastly outweighed by the practical headaches of mixing signed and unsigned values, and more importantly by the far increased likelihood of inadvertent bugs: Because of the broken "viral" nature of unsigned quantities in C (operations involving mixed signed/unsigned are done unsigned, when exactly the opposite is nearly always wanted), even a single error in declaring a quantity unsigned that should be signed, or even the even more subtle error of comparing signed and unsigned values and forgetting the necessary cast, can be catastrophic, as comparisons will yield wrong results. -Wsign-compare is turned on specifically to catch this, but this tends to result in a great number of warnings when mixing signed and unsigned, and the casts are annoying. More has been written on this elsewhere. -- All such quantity types just mentioned boil down to EMACS_INT, which is 32 bits on 32-bit machines and 64 bits on 64-bit machines. This is guaranteed to be the same size as Lisp objects of type `int', and (as far as I can tell) of size_t (unsigned!) and ssize_t. The only type below that is not an EMACS_INT is Hashcode, which is an unsigned value of the same size as EMACS_INT. -- Type names should be relatively short (no more than 10 characters or so), with the first letter capitalized and no underscores if they can at all be avoided. -- "count" == a zero-based measurement of some quantity. Includes sizes, offsets, and indexes. -- "bpos" == a one-based measurement of a position in a buffer. "Charbpos" and "Bytebpos" count text in the buffer, rather than bytes in memory; thus Bytebpos does not directly correspond to the memory representation. Use "Membpos" for this. -- "Char" refers to internal-format characters, not to the C type "char", which is really a byte. -- For the actual name changes, see the script below. I ran the following script to do the conversion. (NOTE: This script is idempotent. You can safely run it multiple times and it will not screw up previous results -- in fact, it will do nothing if nothing has changed. Thus, it can be run repeatedly as necessary to handle patches coming in from old workspaces, or old branches.) There are two tags, just before and just after the change: `pre-integral-type-rename' and `post-integral-type-rename'. When merging code from the main trunk into a branch, the best thing to do is first merge up to `pre-integral-type-rename', then apply the script and associated changes, then merge from `post-integral-type-change' to the present. (Alternatively, just do the merging in one operation; but you may then have a lot of conflicts needing to be resolved by hand.) Script `fixtypes.sh' follows: ----------------------------------- cut ------------------------------------ files="*.[ch] s/*.h m/*.h config.h.in ../configure.in Makefile.in.in ../lib-src/*.[ch] ../lwlib/*.[ch]" gr Memory_Count Bytecount $files gr Lstream_Data_Count Bytecount $files gr Element_Count Elemcount $files gr Hash_Code Hashcode $files gr extcount bytecount $files gr bufpos charbpos $files gr bytind bytebpos $files gr memind membpos $files gr bufbyte intbyte $files gr Extcount Bytecount $files gr Bufpos Charbpos $files gr Bytind Bytebpos $files gr Memind Membpos $files gr Bufbyte Intbyte $files gr EXTCOUNT BYTECOUNT $files gr BUFPOS CHARBPOS $files gr BYTIND BYTEBPOS $files gr MEMIND MEMBPOS $files gr BUFBYTE INTBYTE $files gr MEMORY_COUNT BYTECOUNT $files gr LSTREAM_DATA_COUNT BYTECOUNT $files gr ELEMENT_COUNT ELEMCOUNT $files gr HASH_CODE HASHCODE $files ----------------------------------- cut ------------------------------------ `fixtypes.sh' is a Bourne-shell script; it uses 'gr': ----------------------------------- cut ------------------------------------ #!/bin/sh # Usage is like this: # gr FROM TO FILES ... # globally replace FROM with TO in FILES. FROM and TO are regular expressions. # backup files are stored in the `backup' directory. from="$1" to="$2" shift 2 echo ${1+"$@"} | xargs global-replace "s/$from/$to/g" ----------------------------------- cut ------------------------------------ `gr' in turn uses a Perl script to do its real work, `global-replace', which follows: ----------------------------------- cut ------------------------------------ : #-*- Perl -*- ### global-modify --- modify the contents of a file by a Perl expression ## Copyright (C) 1999 Martin Buchholz. ## Copyright (C) 2001 Ben Wing. ## Authors: Martin Buchholz <martin@xemacs.org>, Ben Wing <ben@xemacs.org> ## Maintainer: Ben Wing <ben@xemacs.org> ## Current Version: 1.0, May 5, 2001 # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with XEmacs; see the file COPYING. If not, write to the Free # Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. eval 'exec perl -w -S $0 ${1+"$@"}' if 0; use strict; use FileHandle; use Carp; use Getopt::Long; use File::Basename; (my $myName = $0) =~ s@.*/@@; my $usage=" Usage: $myName [--help] [--backup-dir=DIR] [--line-mode] [--hunk-mode] PERLEXPR FILE ... Globally modify a file, either line by line or in one big hunk. Typical usage is like this: [with GNU print, GNU xargs: guaranteed to handle spaces, quotes, etc. in file names] find . -name '*.[ch]' -print0 | xargs -0 $0 's/\bCONST\b/const/g'\n [with non-GNU print, xargs] find . -name '*.[ch]' -print | xargs $0 's/\bCONST\b/const/g'\n The file is read in, either line by line (with --line-mode specified) or in one big hunk (with --hunk-mode specified; it's the default), and the Perl expression is then evalled with \$_ set to the line or hunk of text, including the terminating newline if there is one. It should destructively modify the value there, storing the changed result in \$_. Files in which any modifications are made are backed up to the directory specified using --backup-dir, or to `backup' by default. To disable this, use --backup-dir= with no argument. Hunk mode is the default because it is MUCH MUCH faster than line-by-line. Use line-by-line only when it matters, e.g. you want to do a replacement only once per line (the default without the `g' argument). Conversely, when using hunk mode, *ALWAYS* use `g'; otherwise, you will only make one replacement in the entire file! "; my %options = (); $Getopt::Long::ignorecase = 0; &GetOptions ( \%options, 'help', 'backup-dir=s', 'line-mode', 'hunk-mode', ); die $usage if $options{"help"} or @ARGV <= 1; my $code = shift; die $usage if grep (-d || ! -w, @ARGV); sub SafeOpen { open ((my $fh = new FileHandle), $_[0]); confess "Can't open $_[0]: $!" if ! defined $fh; return $fh; } sub SafeClose { close $_[0] or confess "Can't close $_[0]: $!"; } sub FileContents { my $fh = SafeOpen ("< $_[0]"); my $olddollarslash = $/; local $/ = undef; my $contents = <$fh>; $/ = $olddollarslash; return $contents; } sub WriteStringToFile { my $fh = SafeOpen ("> $_[0]"); binmode $fh; print $fh $_[1] or confess "$_[0]: $!\n"; SafeClose $fh; } foreach my $file (@ARGV) { my $changed_p = 0; my $new_contents = ""; if ($options{"line-mode"}) { my $fh = SafeOpen $file; while (<$fh>) { my $save_line = $_; eval $code; $changed_p = 1 if $save_line ne $_; $new_contents .= $_; } } else { my $orig_contents = $_ = FileContents $file; eval $code; if ($_ ne $orig_contents) { $changed_p = 1; $new_contents = $_; } } if ($changed_p) { my $backdir = $options{"backup-dir"}; $backdir = "backup" if !defined ($backdir); if ($backdir) { my ($name, $path, $suffix) = fileparse ($file, ""); my $backfulldir = $path . $backdir; my $backfile = "$backfulldir/$name"; mkdir $backfulldir, 0755 unless -d $backfulldir; print "modifying $file (original saved in $backfile)\n"; rename $file, $backfile; } WriteStringToFile ($file, $new_contents); } } ----------------------------------- cut ------------------------------------ In addition to those programs, I needed to fix up a few other things, particularly relating to the duplicate definitions of types, now that some types merged with others. Specifically: 1. in lisp.h, removed duplicate declarations of Bytecount. The changed code should now look like this: (In each code snippet below, the first and last lines are the same as the original, as are all lines outside of those lines. That allows you to locate the section to be replaced, and replace the stuff in that section, verifying that there isn't anything new added that would need to be kept.) --------------------------------- snip ------------------------------------- /* Counts of bytes or chars */ typedef EMACS_INT Bytecount; typedef EMACS_INT Charcount; /* Counts of elements */ typedef EMACS_INT Elemcount; /* Hash codes */ typedef unsigned long Hashcode; /* ------------------------ dynamic arrays ------------------- */ --------------------------------- snip ------------------------------------- 2. in lstream.h, removed duplicate declaration of Bytecount. Rewrote the comment about this type. The changed code should now look like this: --------------------------------- snip ------------------------------------- #endif /* The have been some arguments over the what the type should be that specifies a count of bytes in a data block to be written out or read in, using Lstream_read(), Lstream_write(), and related functions. Originally it was long, which worked fine; Martin "corrected" these to size_t and ssize_t on the grounds that this is theoretically cleaner and is in keeping with the C standards. Unfortunately, this practice is horribly error-prone due to design flaws in the way that mixed signed/unsigned arithmetic happens. In fact, by doing this change, Martin introduced a subtle but fatal error that caused the operation of sending large mail messages to the SMTP server under Windows to fail. By putting all values back to be signed, avoiding any signed/unsigned mixing, the bug immediately went away. The type then in use was Lstream_Data_Count, so that it be reverted cleanly if a vote came to that. Now it is Bytecount. Some earlier comments about why the type must be signed: This MUST BE SIGNED, since it also is used in functions that return the number of bytes actually read to or written from in an operation, and these functions can return -1 to signal error. Note that the standard Unix read() and write() functions define the count going in as a size_t, which is UNSIGNED, and the count going out as an ssize_t, which is SIGNED. This is a horrible design flaw. Not only is it highly likely to lead to logic errors when a -1 gets interpreted as a large positive number, but operations are bound to fail in all sorts of horrible ways when a number in the upper-half of the size_t range is passed in -- this number is unrepresentable as an ssize_t, so code that checks to see how many bytes are actually written (which is mandatory if you are dealing with certain types of devices) will get completely screwed up. --ben */ typedef enum lstream_buffering --------------------------------- snip ------------------------------------- 3. in dumper.c, there are four places, all inside of switch() statements, where XD_BYTECOUNT appears twice as a case tag. In each case, the two case blocks contain identical code, and you should *REMOVE THE SECOND* and leave the first.
author ben
date Thu, 20 Sep 2001 06:31:11 +0000
parents 023b83f4e54b
children 943eaba38521
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; cmdloop.el --- support functions for the top-level command loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 ;; Author: Richard Mlynarik
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Date: 8-Jul-92
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; Keywords: internal, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; along with XEmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 ;; This file is dumped with XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 ;;; Code:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 (defun recursion-depth ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 "Return the current depth in recursive edits."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 (+ command-loop-level (minibuffer-depth)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 (defun top-level ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 "Exit all recursive editing levels."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 (throw 'top-level nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 (defun exit-recursive-edit ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 "Exit from the innermost recursive edit or minibuffer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 (if (> (recursion-depth) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 (throw 'exit nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 (error "No recursive edit is in progress"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 (defun abort-recursive-edit ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 "Abort the command that requested this recursive edit or minibuffer input."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 (if (> (recursion-depth) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 (throw 'exit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 (error "No recursive edit is in progress"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 ;; (defun keyboard-quit ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 ;; "Signal a `quit' condition."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 ;; (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 ;; (deactivate-mark)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 ;; (signal 'quit nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 ;; moved here from pending-del.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 (defun keyboard-quit ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 "Signal a `quit' condition.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 If this character is typed while lisp code is executing, it will be treated
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 as an interrupt.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 If this character is typed at top-level, this simply beeps.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 If `zmacs-regions' is true, and the zmacs region is active in this buffer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 then this key deactivates the region without beeping or signalling."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 (if (and (region-active-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 (eq (current-buffer) (zmacs-region-buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 ;; deactivating the region. If it is inactive, beep.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 (signal 'quit nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 (defvar buffer-quit-function nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 "Function to call to \"quit\" the current buffer, or nil if none.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 \\[keyboard-escape-quit] calls this function when its more local actions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 \(such as cancelling a prefix argument, minibuffer or region) do not apply.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 (defun keyboard-escape-quit ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 "Exit the current \"mode\" (in a generalized sense of the word).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 This command can exit an interactive command such as `query-replace',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 can clear out a prefix argument or a region,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 can get out of the minibuffer or other recursive edit,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 cancel the use of the current buffer (for special-purpose buffers),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 or go back to just one window (by deleting all but the selected window)."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 (cond ((eq last-command 'mode-exited) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 ((> (minibuffer-depth) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 (abort-recursive-edit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 (current-prefix-arg
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 ((region-active-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 (zmacs-deactivate-region))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 ((> (recursion-depth) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 (exit-recursive-edit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (buffer-quit-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 (funcall buffer-quit-function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 ((not (one-window-p t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 (delete-other-windows))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 ((string-match "^ \\*" (buffer-name (current-buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (bury-buffer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 ;; `cancel-mode-internal' is a function of a misc-user event, which is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 ;; queued when window system directs XEmacs frame to cancel any modal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 ;; behavior it exposes, like mouse pointer grabbing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 ;; This function does nothing at the top level, but the code which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 ;; runs modal event loops, such as selection drag loop in `mouse-track',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 ;; check if misc-user function symbol is `cancel-mode-internal', and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 ;; takes necessary cleanup actions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 (defun cancel-mode-internal (object)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (setq zmacs-region-stays t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 ;; Someone wrote: "This should really be a ring of last errors."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 ;; But why bother? This stuff is not all that necessary now that we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 ;; have message log, anyway.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (defvar last-error nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 "Object describing the last signaled error.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (defcustom errors-deactivate-region nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 "*Non-nil means that errors will cause the region to be deactivated."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 :type 'boolean
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 :group 'editing-basics)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (defun command-error (error-object)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
133 (let* ((old-debug-on-error debug-on-error)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
134 (inhibit-quit t)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
135 (debug-on-error nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
136 (etype (car-safe error-object)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 (setq quit-flag nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 (setq standard-output t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (setq standard-input t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 (setq executing-kbd-macro nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 (and errors-deactivate-region
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (zmacs-deactivate-region))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (discard-input)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 (setq last-error error-object)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (message nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (ding nil (cond ((eq etype 'undefined-keystroke-sequence)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 (if (and (vectorp (nth 1 error-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (/= 0 (length (nth 1 error-object)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 (button-event-p (aref (nth 1 error-object) 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 'undefined-click
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 'undefined-key))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 ((eq etype 'quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 'quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 ((memq etype '(end-of-buffer beginning-of-buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 'buffer-bound)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 ((eq etype 'buffer-read-only)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 'read-only)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (t 'command-error)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 (display-error error-object t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (if (noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 (progn
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
165 (if old-debug-on-error
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
166 (progn
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
167 (message "Backtrace:\n\n")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
168 (backtrace)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
169 (message "\n")))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
170 (message "%s exiting\n." emacs-program-name)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 (kill-emacs -1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 (defun describe-last-error ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 "Redisplay the last error-message. See the variable `last-error'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 (if last-error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 (with-displaying-help-buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (lambda ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 (princ "Last error was:\n" standard-output)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (display-error last-error standard-output)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (message "No error yet")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 ;;#### Must be done later in the loadup sequence
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 ;(define-key (symbol-function 'help-command) "e" 'describe-last-error)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 (defun truncate-command-history-for-gc ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (let ((tail (nthcdr 30 command-history)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 (if tail (setcdr tail nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 (let ((tail (nthcdr 30 values)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 (if tail (setcdr tail nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 ;;;; Object-oriented programming at its finest
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 ;; Now in src/print.c; used by Ferror_message_string and others
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 ;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 ; "Display `error-object' on `stream' in a user-friendly way."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 ; (funcall (or (let ((type (car-safe error-object)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 ; (catch 'error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 ; (and (consp error-object)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 ; (symbolp type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 ; ;;(stringp (get type 'error-message))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 ; (consp (get type 'error-conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 ; (let ((tail (cdr error-object)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 ; (while (not (null tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 ; (if (consp tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 ; (setq tail (cdr tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 ; (throw 'error nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 ; t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 ; ;; (check-type condition condition)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 ; (get type 'error-conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 ; ;; Search class hierarchy
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 ; (let ((tail (get type 'error-conditions)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 ; (while (not (null tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 ; (cond ((not (and (consp tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 ; (symbolp (car tail))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 ; (throw 'error nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 ; ((get (car tail) 'display-error)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 ; (throw 'error (get (car tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 ; 'display-error)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 ; (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 ; (setq tail (cdr tail)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 ; ;; Default method
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 ; #'(lambda (error-object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 ; (let ((type (car error-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 ; (tail (cdr error-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 ; (first t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 ; (print-message-label 'error))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 ; (if (eq type 'error)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 ; (progn (princ (car tail) stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 ; (setq tail (cdr tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 ; (princ (or (gettext (get type 'error-message)) type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 ; stream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 ; (while tail
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 ; (princ (if first ": " ", ") stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 ; (prin1 (car tail) stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 ; (setq tail (cdr tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 ; first nil))))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 ; #'(lambda (error-object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 ; (princ (gettext "Peculiar error ") stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 ; (prin1 error-object stream)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 ; error-object stream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (put 'file-error 'display-error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 #'(lambda (error-object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (let ((tail (cdr error-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 (first t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 (princ (car tail) stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 (while (setq tail (cdr tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 (princ (if first ": " ", ") stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 (princ (car tail) stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 (setq first nil)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 (put 'undefined-keystroke-sequence 'display-error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 #'(lambda (error-object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 (princ (key-description (car (cdr error-object))) stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 ;; #### I18N3: doesn't localize properly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (princ (gettext " not defined.") stream) ; doo dah, doo dah.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 (defcustom teach-extended-commands-p t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 "*If true, then `\\[execute-extended-command]' will teach you keybindings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 Any time you execute a command with \\[execute-extended-command] which has a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 shorter keybinding, you will be shown the alternate binding before the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 command executes. There is a short pause after displaying the binding,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 before executing it; the length can be controlled by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 `teach-extended-commands-timeout'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 :type 'boolean
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 :group 'keyboard)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 (defcustom teach-extended-commands-timeout 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 "*How long to pause after displaying a keybinding before executing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 The value is measured in seconds. This only applies if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 `teach-extended-commands-p' is true."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 :type 'number
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 :group 'keyboard)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 ;That damn RMS went off and implemented something differently, after
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 ;we had already implemented it. We can't support both properly until
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 ;we have Lisp magic variables.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 ;(defvar suggest-key-bindings t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 ; "*FSFmacs equivalent of `teach-extended-commands-*'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 ;Provided for compatibility only.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 ;Non-nil means show the equivalent key-binding when M-x command has one.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 ;The value can be a length of time to show the message for.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 ;If the value is non-nil and not a number, we wait 2 seconds.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 ;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 (defun execute-extended-command (prefix-arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 "Read a command name from the minibuffer using 'completing-read'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 Then call the specified command using 'command-execute' and return its
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 return value. If the command asks for a prefix argument, supply the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 value of the current raw prefix argument, or the value of PREFIX-ARG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 when called from Lisp."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 (interactive "P")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 ;; Note: This doesn't hack "this-command-keys"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 (let ((prefix-arg prefix-arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 (setq this-command (read-command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 ;; Note: this has the hard-wired
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 ;; "C-u" and "M-x" string bug in common
613
023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben]
ben
parents: 442
diff changeset
309 ;; with all Emacs's.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 ;; (i.e. it prints C-u and M-x regardless of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 ;; whether some other keys were actually bound
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 ;; to `execute-extended-command' and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 ;; `universal-argument'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 (cond ((eq prefix-arg '-)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 "- M-x ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 ((equal prefix-arg '(4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 "C-u M-x ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 ((integerp prefix-arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 (format "%d M-x " prefix-arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 ((and (consp prefix-arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 (integerp (car prefix-arg)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 (format "%d M-x " (car prefix-arg)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 "M-x ")))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 (if (and teach-extended-commands-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (interactive-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 ;; Remember the keys, run the command, and show the keys (if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 ;; any). The funny variable names are a poor man's guarantee
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 ;; that we don't get tripped by this-command doing something
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 ;; funny. Quoth our forefathers: "We want lexical scope!"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 (let ((_execute_command_keys_ (where-is-internal this-command))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 (_execute_command_name_ this-command)) ; the name can change
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 (command-execute this-command t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (when _execute_command_keys_
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 ;; Normally the region is adjusted in post_command_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 ;; however, it is not called until after we finish. It
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 ;; looks ugly for the region to get updated after the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 ;; delays, so we do it now. The code below is a Lispified
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 ;; copy of code in event-stream.c:post_command_hook().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 (if (and (not zmacs-region-stays)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 (or (not (eq (selected-window) (minibuffer-window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 (eq (zmacs-region-buffer) (current-buffer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 (zmacs-deactivate-region)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (zmacs-update-region))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 ;; Wait for a while, so the user can see a message printed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 ;; if any.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 (when (sit-for 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (display-message
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 'no-log
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 (format (if (cdr _execute_command_keys_)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 "Command `%s' is bound to keys: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 "Command `%s' is bound to key: %s")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 _execute_command_name_
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (sorted-key-descriptions _execute_command_keys_)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 (sit-for teach-extended-commands-timeout)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (clear-message 'no-log))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 ;; Else, just run the command.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 (command-execute this-command t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 ;;; C code calls this; the underscores in the variable names are to avoid
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 ;;; cluttering the specbind namespace (lexical scope! lexical scope!)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 ;;; Putting this in Lisp instead of C slows kbd macros by 50%.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 ;(defun command-execute (_command &optional _record-flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 ; "Execute CMD as an editor command.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 ;CMD must be a symbol that satisfies the `commandp' predicate.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 ;Optional second arg RECORD-FLAG non-nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 ;means unconditionally put this command in `command-history'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 ;Otherwise, that is done only if an arg is read using the minibuffer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 ; (let ((_prefix prefix-arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 ; (_cmd (indirect-function _command)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 ; (setq prefix-arg nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 ; this-command _command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 ; current-prefix-arg _prefix
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 ; zmacs-region-stays nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 ; ;; #### debug_on_next_call = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 ; (cond ((and (symbolp _command)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 ; (get _command 'disabled))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 ; (run-hooks disabled-command-hook))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 ; ((or (stringp _cmd) (vectorp _cmd))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 ; ;; If requested, place the macro in the command history.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 ; ;; For other sorts of commands, call-interactively takes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 ; ;; care of this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 ; (if _record-flag
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 ; (setq command-history
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 ; (cons (list 'execute-kbd-macro _cmd _prefix)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 ; command-history)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 ; (execute-kbd-macro _cmd _prefix))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 ; (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 ; (call-interactively _command _record-flag)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 (defun y-or-n-p-minibuf (prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 "Ask user a \"y or n\" question. Return t if answer is \"y\".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 Takes one argument, which is the string to display to ask the question.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 No confirmation of the answer is requested; a single character is enough.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 Also accepts Space to mean yes, or Delete to mean no."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 (let* ((pre "")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 (yn (gettext "(y or n) "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 ;; we need to translate the prompt ourselves because of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 ;; strange way we handle it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 (prompt (gettext prompt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 (while (stringp yn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 (if (let ((cursor-in-echo-area t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 (inhibit-quit t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 (message "%s%s%s" pre prompt yn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 (setq event (next-command-event event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 (prog1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 (or quit-flag (eq 'keyboard-quit (key-binding event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (setq quit-flag nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 (wrong-type-argument t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 (message "%s%s%s%s" pre prompt yn (single-key-description event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (setq quit-flag nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (signal 'quit '())))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (let* ((keys (events-to-keys (vector event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 (def (lookup-key query-replace-map keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 (cond ((eq def 'skip)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 (message "%s%sNo" prompt yn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 (setq yn nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 ((eq def 'act)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (message "%s%sYes" prompt yn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (setq yn t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 ((eq def 'recenter)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 (recenter))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 ((or (eq def 'quit) (eq def 'exit-prefix))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 (signal 'quit '()))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 ((button-release-event-p event) ; ignore them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (message "%s%s%s%s" pre prompt yn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 (single-key-description event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 (ding nil 'y-or-n-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 (discard-input)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 (if (= (length pre) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 (setq pre (gettext "Please answer y or n. ")))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 yn)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 (defun yes-or-no-p-minibuf (prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 "Ask user a yes-or-no question. Return t if answer is yes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 Takes one argument, which is the string to display to ask the question.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 The user must confirm the answer with RET,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 and can edit it until it has been confirmed."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 (let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 (ans ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 (while (stringp ans)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 (setq ans (downcase (read-string p nil t))) ;no history
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 (cond ((string-equal ans (gettext "yes"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 (setq ans t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 ((string-equal ans (gettext "no"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 (setq ans nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 (ding nil 'yes-or-no-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (discard-input)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 (message "Please answer yes or no.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (sleep-for 2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 ans)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
465 (defun yes-or-no-p (prompt)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
466 "Ask user a yes-or-no question. Return t if answer is yes.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
467 The question is asked with a dialog box or the minibuffer, as appropriate.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
468 Takes one argument, which is the string to display to ask the question.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
469 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
470 The user must confirm the answer with RET,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
471 and can edit it until it as been confirmed."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
472 (if (should-use-dialog-box-p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
473 (yes-or-no-p-dialog-box prompt)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
474 (yes-or-no-p-minibuf prompt)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
475
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
476 (defun y-or-n-p (prompt)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
477 "Ask user a \"y or n\" question. Return t if answer is \"y\".
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
478 Takes one argument, which is the string to display to ask the question.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
479 The question is asked with a dialog box or the minibuffer, as appropriate.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
480 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
481 No confirmation of the answer is requested; a single character is enough.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
482 Also accepts Space to mean yes, or Delete to mean no."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
483 (if (should-use-dialog-box-p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
484 (yes-or-no-p-dialog-box prompt)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
485 (y-or-n-p-minibuf prompt)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
486
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 (defun read-char ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 "Read a character from the command input (keyboard or macro).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 If a mouse click or non-ASCII character is detected, an error is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 signalled. The character typed is returned as an ASCII value. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 is most likely the wrong thing for you to be using: consider using
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 the `next-command-event' function instead."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 (let ((event (next-command-event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 (or inhibit-quit
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 (and (event-matches-key-specifier-p event (quit-char))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 (signal 'quit nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 (prog1 (or (event-to-character event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 ;; Kludge. If the event we read was a mouse-release,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 ;; discard it and read the next one.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 (if (button-release-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 (event-to-character (next-command-event event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 (error "Key read has no ASCII equivalent %S" event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 ;; this is not necessary, but is marginally more efficient than GC.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 (deallocate-event event)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 (defun read-char-exclusive ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 "Read a character from the command input (keyboard or macro).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 If a mouse click or non-ASCII character is detected, it is discarded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 The character typed is returned as an ASCII value. This is most likely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 the wrong thing for you to be using: consider using the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 `next-command-event' function instead."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 (let (event ch)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 (while (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 (setq event (next-command-event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 (or inhibit-quit
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 (and (event-matches-key-specifier-p event (quit-char))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 (signal 'quit nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 (setq ch (event-to-character event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 (deallocate-event event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 (null ch)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 ch))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 (defun read-quoted-char (&optional prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 "Like `read-char', except that if the first character read is an octal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 digit, we read up to two more octal digits and return the character
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 represented by the octal number consisting of those digits.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 Optional argument PROMPT specifies a string to use to prompt the user."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 (let ((count 0) (code 0) done
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 (prompt (and prompt (gettext prompt)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 char event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 (while (and (not done) (< count 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 (let ((inhibit-quit (zerop count))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 ;; Don't let C-h get the help message--only help function keys.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 (help-char nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 (help-form
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 "Type the special character you want to use,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 or three octal digits representing its character code."))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 (and prompt (display-message 'prompt (format "%s-" prompt)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 (setq event (next-command-event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 char (or (event-to-character event nil nil t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 (signal 'error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 (list "key read cannot be inserted in a buffer"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 (if inhibit-quit (setq quit-flag nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 (cond ((<= ?0 char ?7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 (setq code (+ (* code 8) (- char ?0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 count (1+ count))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 (when prompt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 (display-message 'prompt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 (setq prompt (format "%s %c" prompt char)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 ((> count 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 (setq unread-command-event event
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 done t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 (t (setq code (char-int char)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 done t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 (int-char code)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 ;; Turn a meta-character into a character with the 0200 bit set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 ; (logior (if (/= (logand code ?\M-\^@) 0) 128 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 ; (logand 255 code))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 (defun momentary-string-display (string pos &optional exit-char message)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 "Momentarily display STRING in the buffer at POS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 Display remains until next character is typed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 otherwise it is then available as input (as a command if nothing else).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 Display MESSAGE (optional fourth arg) in the echo area.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (or exit-char (setq exit-char ?\ ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 (let ((buffer-read-only nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 ;; Don't modify the undo list at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 (buffer-undo-list t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 (modified (buffer-modified-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 (name buffer-file-name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 insert-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 (unwind-protect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 (goto-char pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 ;; defeat file locking... don't try this at home, kids!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 (setq buffer-file-name nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 (insert-before-markers (gettext string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 (setq insert-end (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 ;; If the message end is off frame, recenter now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (if (> (window-end) insert-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 (recenter (/ (window-height) 2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 ;; If that pushed message start off the frame,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 ;; scroll to start it at the top of the frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 (move-to-window-line 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (if (> (point) pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 (goto-char pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 (recenter 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 (message (or message (gettext "Type %s to continue editing."))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 (single-key-description exit-char))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 (let ((event (save-excursion (next-command-event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 (or (eq (event-to-character event) exit-char)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 (setq unread-command-event event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 (if insert-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 (delete-region pos insert-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 (setq buffer-file-name name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 (set-buffer-modified-p modified))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 ;;; cmdloop.el ends here