annotate lisp/keymap.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 7039e6323819
children 79940b592197
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 ;; keymap.el --- Keymap functions for XEmacs.
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) 1993-4, 1997 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Keywords: internals, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; along with XEmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 ;;; Synched up with: FSF 19.28.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 ;; This file is dumped with XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 ;;; Note: FSF does not have a file keymap.el. This stuff is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 ;;; in keymap.c.
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 ;Prevent the \{...} documentation construct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 ;from mentioning keys that run this command.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 ;;; Code:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 (put 'undefined 'suppress-keymap t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 (defun undefined ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 (ding))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 (defmacro kbd (keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 "Convert KEYS to the internal Emacs key representation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 KEYS should be a string in the format used for saving keyboard macros
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 \(see `insert-kbd-macro')."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 (if (or (stringp keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 (vectorp keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 (read-kbd-macro keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 `(read-kbd-macro ,keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 (defun suppress-keymap (map &optional nodigits)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 "Make MAP override all normally self-inserting keys to be undefined.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 Normally, as an exception, digits and minus-sign are set to make prefix args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 but optional second arg NODIGITS non-nil treats them like other chars."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 (substitute-key-definition 'self-insert-command 'undefined map global-map)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 (or nodigits
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 (let ((string (make-string 1 ?0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 (define-key map "-" 'negative-argument)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 ;; Make plain numbers do numeric args.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 (while (<= (aref string 0) ?9)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 (define-key map string 'digit-argument)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 (incf (aref string 0))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 In other words, OLDDEF is replaced with NEWDEF wherever it appears.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 Prefix keymaps are checked recursively. If optional fourth argument OLDMAP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 is specified, we redefine in KEYMAP as NEWDEF those chars which are defined
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
73 as OLDDEF in OLDMAP, unless that keybinding is already present in KEYMAP.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
74 If optional fifth argument PREFIX is non-nil, then only those occurrences of
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 OLDDEF found in keymaps accessible through the keymap bound to PREFIX in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 KEYMAP are redefined. See also `accessible-keymaps'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 (let ((maps (accessible-keymaps (or oldmap keymap) prefix))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 (shadowing (not (null oldmap)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 prefix map)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 (while maps
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 (setq prefix (car (car maps))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 map (cdr (car maps))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 maps (cdr maps))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 ;; Substitute in this keymap
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 (map-keymap #'(lambda (key binding)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (if (eq binding olddef)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 ;; The new bindings always go in KEYMAP even if we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 ;; found them in OLDMAP or one of its children.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 ;; If KEYMAP will be shadowing OLDMAP, then do not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 ;; redefine the key if there is another binding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 ;; in KEYMAP that will shadow OLDDEF.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 (or (and shadowing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 (lookup-key keymap key))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 ;; define-key will give an error if a prefix
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 ;; of the key is already defined. Otherwise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 ;; it will define the key in the map.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 ;; #### - Perhaps this should be protected?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (define-key
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 keymap
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 (vconcat prefix (list key))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 newdef))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 map)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 ;; This used to wrap forms into an interactive lambda. It is unclear
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 ;; to me why this is needed in this function. Anyway,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 ;; `key-or-menu-binding' doesn't do it, so this function no longer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 ;; does it, either.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (defun insert-key-binding (key) ; modeled after describe-key
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 "Insert the command bound to KEY."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 (interactive "kInsert command bound to key: ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (let ((defn (key-or-menu-binding key)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 (if (or (null defn) (integerp defn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 (error "%s is undefined" (key-description key))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 (if (or (stringp defn) (vectorp defn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 (setq defn (key-binding defn))) ;; a keyboard macro
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (insert (format "%s" defn)))))
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 (defun read-command-or-command-sexp (prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 "Read a command symbol or command sexp.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 A command sexp is wrapped in an interactive lambda if needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 Prompts with PROMPT."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 ;; Todo: it would be better if we could reject symbols that are not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 ;; commandp (as does 'read-command') but that is not easy to do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 ;; because we must supply arg4 = require-match = nil for sexp case.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (let ((result (car (read-from-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (completing-read prompt obarray 'commandp)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (if (and (consp result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (not (eq (car result) 'lambda)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 `(lambda ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 ,result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 result)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
136 (defun local-key-binding (keys &optional accept-defaults)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 "Return the binding for command KEYS in current local keymap only.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 KEYS is a string, a vector of events, or a vector of key-description lists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 as described in the documentation for the `define-key' function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 The binding is probably a symbol with a function definition; see
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 the documentation for `lookup-key' for more information."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (let ((map (current-local-map)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (if map
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
144 (lookup-key map keys accept-defaults)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
147 (defun global-key-binding (keys &optional accept-defaults)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 "Return the binding for command KEYS in current global keymap only.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 KEYS is a string or vector of events, a sequence of keystrokes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 The binding is probably a symbol with a function definition; see
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 the documentation for `lookup-key' for more information."
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
152 (lookup-key (current-global-map) keys accept-defaults))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 (defun global-set-key (key command)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 "Give KEY a global binding as COMMAND.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 COMMAND is a symbol naming an interactively-callable function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 KEY is a string, a vector of events, or a vector of key-description lists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 as described in the documentation for the `define-key' function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 Note that if KEY has a local binding in the current buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 that local binding will continue to shadow any global binding."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 ;;(interactive "KSet key globally: \nCSet key %s to command: ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 (interactive (list (setq key (read-key-sequence "Set key globally: "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 ;; Command sexps are allowed here so that this arg
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 ;; may be supplied interactively via insert-key-binding.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 (read-command-or-command-sexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 (format "Set key %s to command: "
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 (key-description key)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 (define-key (current-global-map) key command)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 (defun local-set-key (key command)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 "Give KEY a local binding as COMMAND.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 COMMAND is a symbol naming an interactively-callable function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 KEY is a string, a vector of events, or a vector of key-description lists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 as described in the documentation for the `define-key' function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 The binding goes in the current buffer's local map,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 which is shared with other buffers in the same major mode."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 ;;(interactive "KSet key locally: \nCSet key %s locally to command: ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (interactive (list (setq key (read-key-sequence "Set key locally: "))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 ;; Command sexps are allowed here so that this arg
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 ;; may be supplied interactively via insert-key-binding.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (read-command-or-command-sexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 (format "Set key %s locally to command: "
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 (key-description key)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 (if (null (current-local-map))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 (use-local-map (make-sparse-keymap)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (define-key (current-local-map) key command)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (defun global-unset-key (key)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 "Remove global binding of KEY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 KEY is a string, a vector of events, or a vector of key-description lists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 as described in the documentation for the `define-key' function."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 (interactive "kUnset key globally: ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (global-set-key key nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 (defun local-unset-key (key)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 "Remove local binding of KEY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 KEY is a string, a vector of events, or a vector of key-description lists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 as described in the documentation for the `define-key' function."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 (interactive "kUnset key locally: ")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 (if (current-local-map)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 (define-key (current-local-map) key nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 ;; FSF-inherited brain-death.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 (defun minor-mode-key-binding (key &optional accept-default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 "Find the visible minor mode bindings of KEY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 Return an alist of pairs (MODENAME . BINDING), where MODENAME is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 the symbol which names the minor mode binding KEY, and BINDING is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 KEY's definition in that mode. In particular, if KEY has no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 minor-mode bindings, return nil. If the first binding is a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 non-prefix, all subsequent bindings will be omitted, since they would
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 be ignored. Similarly, the list doesn't include non-prefix bindings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 that come after prefix bindings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 If optional argument ACCEPT-DEFAULT is non-nil, recognize default
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 bindings; see the description of `lookup-key' for more details about this."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 (let ((tail minor-mode-map-alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 a s v)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 (while tail
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 (setq a (car tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 tail (cdr tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 (and (consp a)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 (symbolp (setq s (car a)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 (boundp s)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 (symbol-value s)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 ;; indirect-function deals with autoloadable keymaps
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 (setq v (indirect-function (cdr a)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 (setq v (lookup-key v key accept-default))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 ;; Terminate loop, with v set to non-nil value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 (setq tail nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 v))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 (defun current-minor-mode-maps ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 "Return a list of keymaps for the minor modes of the current buffer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 (let ((l '())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 (tail minor-mode-map-alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 a s v)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 (while tail
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 (setq a (car tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 tail (cdr tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 (and (consp a)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 (symbolp (setq s (car a)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 (boundp s)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 (symbol-value s)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 ;; indirect-function deals with autoloadable keymaps
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 (setq v (indirect-function (cdr a)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (setq l (cons v l))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 (nreverse l)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 ;;#### What a crock
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 (defun define-prefix-command (name &optional mapvar)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 "Define COMMAND as a prefix command.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 A new sparse keymap is stored as COMMAND's function definition.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 If second optional argument MAPVAR is not specified,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 COMMAND's value (as well as its function definition) is set to the keymap.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 If a second optional argument MAPVAR is given and is not `t',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 the map is stored as its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 Regardless of MAPVAR, COMMAND's function-value is always set to the keymap."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 (let ((map (make-sparse-keymap name)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (fset name map)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 (cond ((not mapvar)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 (set name map))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 ((eq mapvar 't)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 (set mapvar map)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 ;;; Converting vectors of events to a read-equivalent form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 ;;; This is used both by call-interactively (for the command history)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 ;;; and by macros.el (for saving keyboard macros to a file).
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 ;; #### why does (events-to-keys [backspace]) return "\C-h"?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 ;; BTW, this function is a mess, and macros.el does *not* use it, in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 ;; spite of the above comment. `format-kbd-macro' is used to save
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 ;; keyboard macros to a file.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 (defun events-to-keys (events &optional no-mice)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 "Given a vector of event objects, returns a vector of key descriptors,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 or a string (if they all fit in the ASCII range).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 Optional arg NO-MICE means that button events are not allowed."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 (if (and events (symbolp events)) (setq events (vector events)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 (cond ((stringp events)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 events)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 ((not (vectorp events))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 (signal 'wrong-type-argument (list 'vectorp events)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 ((let* ((length (length events))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 (string (make-string length 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 c ce
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 (i 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 (while (< i length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 (setq ce (aref events i))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 (or (eventp ce) (setq ce (character-to-event ce)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 ;; By passing t for the `allow-meta' arg we could get kbd macros
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 ;; with meta in them to translate to the string form instead of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 ;; the list/symbol form; but I expect that would cause confusion,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 ;; so let's use the list/symbol form whenever there's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 ;; any ambiguity.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 (setq c (event-to-character ce))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 (if (and c
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 character-set-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 (key-press-event-p ce))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 (cond ((symbolp (event-key ce))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 (if (get (event-key ce) character-set-property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 ;; Don't use a string for `backspace' and `tab' to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 ;; avoid that unpleasant little ambiguity.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 (setq c nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 ((and (= (event-modifier-bits ce) 1) ;control
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 (integerp (event-key ce)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 (let* ((te (character-to-event c)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 (if (and (symbolp (event-key te))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 (get (event-key te) character-set-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 ;; Don't "normalize" (control i) to tab
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 ;; to avoid the ambiguity in the other direction
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 (setq c nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 (deallocate-event te)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 (if c
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (aset string i c)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 (setq i length string nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 (let* ((length (length events))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 (new (copy-sequence events))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 event mods key
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 (i 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 (while (< i length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 (setq event (aref events i))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 (cond ((key-press-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (setq mods (event-modifiers event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 key (event-key event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 (if (numberp key)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 (setq key (intern (make-string 1 key))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 (aset new i (if mods
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 (nconc mods (cons key nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 key)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 ((misc-user-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 (aset new i (list 'menu-selection
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 (event-function event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (event-object event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 ((or (button-press-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 (button-release-event-p event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 (if no-mice
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 "Mouse events can't be saved in keyboard macros."))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 (setq mods (event-modifiers event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 key (intern (format "button%d%s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 (event-button event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 (if (button-release-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 "up" ""))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 (aset new i (if mods
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (nconc mods (cons key nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 key)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 ((or (and event (symbolp event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 (and (consp event) (symbolp (car event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 (aset new i event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 (signal 'wrong-type-argument (list 'eventp event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 new))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 (defun next-key-event ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 "Return the next available keyboard event."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 (let (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 (while (not (key-press-event-p (setq event (next-command-event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 (dispatch-event event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 (defun key-sequence-list-description (keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 "Convert a key sequence KEYS to the full [(modifiers... key)...] form.
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
377 Argument KEYS can be in any form accepted by `define-key' function.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
378 The output is always in a canonical form, meaning you can use this
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
379 function to determine if two key sequence specifications are equivalent
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
380 by comparing the respective outputs of this function using `equal'."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 (let ((vec
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
382 (cond ((vectorp keys)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
383 keys)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
384 ((stringp keys)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
385 (vconcat keys))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
386 (t
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
387 (vector keys)))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
388 (flet ((event-to-list (ev)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
389 (append (event-modifiers ev) (list (event-key ev)))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
390 (mapvector
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
391 #'(lambda (key)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
392 (let* ((full-key
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
393 (cond ((key-press-event-p key)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
394 (event-to-list key))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
395 ((characterp key)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
396 (event-to-list (character-to-event key)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
397 ((listp key)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
398 (copy-sequence key))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
399 (t
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
400 (list key))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
401 (keysym (car (last full-key))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
402 (if (characterp keysym)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
403 (setcar (last full-key) (intern (char-to-string keysym))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
404 full-key))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
405 vec))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 ;;; Support keyboard commands to turn on various modifiers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 ;;; These functions -- which are not commands -- each add one modifier
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 ;;; to the following event.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 (defun event-apply-alt-modifier (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (event-apply-modifier 'alt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 (defun event-apply-super-modifier (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 (event-apply-modifier 'super))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 (defun event-apply-hyper-modifier (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (event-apply-modifier 'hyper))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (defun event-apply-shift-modifier (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (event-apply-modifier 'shift))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 (defun event-apply-control-modifier (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 (event-apply-modifier 'control))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 (defun event-apply-meta-modifier (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 (event-apply-modifier 'meta))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 ;;; #### `key-translate-map' is ignored for now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (defun event-apply-modifier (symbol)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 "Return the next key event, with a modifier flag applied.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 SYMBOL is the name of this modifier, as a symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 `function-key-map' is scanned for prefix bindings."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 (let (events binding)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 ;; read keystrokes scanning `function-key-map'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 (while (keymapp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 (setq binding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (lookup-key
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 function-key-map
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 (vconcat
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 (setq events
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 (append events (list (next-key-event)))))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 (if binding ; found a binding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 ;; allow for several modifiers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 (if (and (symbolp binding) (fboundp binding))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 (setq binding (funcall binding nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 (setq events (append binding nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 ;; put remaining keystrokes back into input queue
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 (setq unread-command-events
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 (mapcar 'character-to-event (cdr events))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 (setq unread-command-events (cdr events)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 ;; add a modifier SYMBOL to the first keystroke or event
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 (vector
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 (append (list symbol)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 (delq symbol
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 (aref (key-sequence-list-description (car events)) 0))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 (defun synthesize-keysym (ignore-prompt)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 "Read a sequence of keys, and returned the corresponding key symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 The characters must be from the [-_a-zA-Z0-9]. Reading is terminated
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 by RET (which is discarded)."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (let ((continuep t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 event char list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (while continuep
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 (setq event (next-key-event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (cond ((and (setq char (event-to-character event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 (or (memq char '(?- ?_))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 (eq ?w (char-syntax char (standard-syntax-table)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 ;; Advance a character.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 (push char list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 ((or (memq char '(?\r ?\n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (memq (event-key event) '(return newline)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 ;; Legal termination.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 (setq continuep nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 (char
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 ;; Illegal character.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 (error "Illegal character in keysym: %c" char))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 ;; Illegal event.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 (error "Event has no character equivalent: %s" event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 (vector (intern (concat "" (nreverse list))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 ;; This looks dirty. The following code should maybe go to another
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 ;; file, and `create-console-hook' should maybe default to nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 (add-hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 'create-console-hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 #'(lambda (console)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 (letf (((selected-console) console))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 (define-key function-key-map [?\C-x ?@ ?k] 'synthesize-keysym))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 ;;; keymap.el ends here