mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-25 10:47:00 +00:00
Code Issues Releases Activity

*** empty log message ***

Browse Source
This commit is contained in:
Jim Blandy 1991-12-20 07:15:37 +00:00
parent 6367dc09a1
commit cc0a8174ba
3 changed files with 376 additions and 309 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

390
lisp/mouse.el
View File

@ -1,170 +1,95 @@
;; Mouse support that is independent of window systems.
;; Copyright (C) 1988 Free Software Foundation, Inc.
;;; Window system-independent mouse support.
;;; Copyright (C) 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;;; This file is part of GNU Emacs.
;; GNU Emacs 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 1, or (at your option)
;; any later version.
;;; GNU Emacs 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 1, or (at your option)
;;; any later version.
;; GNU Emacs 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.
;;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Emacs; see the file COPYING. If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(provide 'mouse)
(defun mouse-select ()
"Select the Emacs window the mouse is on."
(interactive "@"))
;;; Utility functions.
(defun mouse-delete-window ()
"Delete the Emacs window the mouse is on."
(interactive "@")
(delete-window))
(defun mouse-movement-p (event)
(and (consp event)
(eq (car event) 'mouse-movement)))
(defun mouse-keep-one-window ()
"Select Emacs window mouse is on, then kill all other Emacs windows."
(interactive "@")
(defun event-window (event) (nth 1 event))
(defun event-point (event) (nth 2 event))
(defun mouse-coords (event) (nth 3 event))
(defun mouse-timestamp (event) (nth 4 event))
;;; Indent track-mouse like progn.
(put 'track-mouse 'lisp-indent-function 0)
(defun mouse-delete-window (click)
"Delete the window clicked on.
This must be bound to a mouse click."
(interactive "K")
(delete-window (event-window click)))
(defun mouse-delete-other-windows (click)
"Select Emacs window clicked on, then kill all other Emacs windows.
This must be bound to a mouse click."
(interactive "K")
(select-window (event-window click))
(delete-other-windows))
(defun mouse-select-and-split ()
"Select Emacs window mouse is on, then split it vertically in half."
(interactive "@")
(split-window-vertically nil))
(defun mouse-split-window-vertically (click)
"Select Emacs window mouse is on, then split it vertically in half.
The window is split at the line clicked on.
This command must be bound to a mouse click."
(interactive "K")
(select-window (event-window click))
(split-window-vertically (1+ (cdr (mouse-coords click)))))
(defun mouse-set-point (event)
"Select Emacs window mouse is on, and move point to mouse position."
(interactive "@e")
(let ((relative-coordinate
(coordinates-in-window-p (car event) (selected-window))))
(if (consp relative-coordinate)
(progn
(move-to-window-line (car (cdr relative-coordinate)))
;; Note that hscroll must get above 1
;; before the text actually starts to move.
(move-to-column (+ (car relative-coordinate) (current-column)
(1- (max 1 (window-hscroll (selected-window))))))
(what-line)))))
(defun mouse-set-point (click)
"Move point to the position clicked on with the mouse.
This must be bound to a mouse click."
(interactive "K")
(select-window (event-window click))
(goto-char (event-point click)))
(defun mouse-eval-last-sexpr (event)
(interactive "@e")
(save-excursion
(mouse-set-point event)
(eval-last-sexp nil)))
(defun mouse-line-length (event)
"Print the length of the line indicated by the pointer."
(interactive "@e")
(let ((relative-coordinate
(coordinates-in-window-p (car event) (selected-window))))
(if (consp relative-coordinate)
(save-excursion
(move-to-window-line (car (cdr relative-coordinate)))
(end-of-line)
(push-mark nil t)
(beginning-of-line)
(message "Line length: %d"
(- (region-end) (region-beginning)))
(sleep-for 1)))))
(defun mouse-set-mark (event)
"Select Emacs window mouse is on, and set mark at mouse position.
Display cursor at that position for a second."
(interactive "@e")
(defun mouse-set-mark (click)
"Set mark at the position clicked on with the mouse.
Display cursor at that position for a second.
This must be bound to a mouse click."
(interactive "K")
(let ((point-save (point)))
(unwind-protect
(progn (mouse-set-point event)
(progn (mouse-set-point click)
(push-mark nil t)
(sit-for 1))
(goto-char point-save))))
(defun mouse-fill-paragraph (event)
"Fill the paragraph at the mouse position."
(interactive "@e")
(save-excursion
(mouse-set-point event)
(fill-paragraph)))
(defun mouse-kill (click)
"Kill the region between point and the mouse click.
The text is saved in the kill ring, as with \\[kill-region]."
(interactive "K")
(mouse-set-mark click)
(kill-region))
(defun mouse-fill-paragraph-with-prefix (event)
"Fill the paragraph at the mouse position with specified fill prefix.
Click at the end of the fill prefix that you want;
The text before the mouse position, on the same line, is used as the prefix."
(interactive "@e")
(save-excursion
(mouse-set-point event)
(let ((fill-prefix (buffer-substring (save-excursion (beginning-of-line)
(point))
(point))))
(fill-paragraph))))
(defun mouse-kill-ring-save
"Copy the region between point and the mouse click in the kill ring.
This does not delete the region; it acts like \\[kill-ring-save]."
(interactive "K")
(mouse-set-mark click)
(kill-ring-save))
(defun mouse-scroll (event)
"Scroll point to the mouse position."
(interactive "@e")
(let ((relative-coordinate
(coordinates-in-window-p (car event) (selected-window))))
(if (consp relative-coordinate)
(progn
(recenter (car (cdr relative-coordinate)))
(scroll-right (+ (car relative-coordinate) (current-column)))))))
(defun mouse-del-char (event)
"Delete the char pointed to by the mouse."
(interactive "@e")
(let ((relative-coordinate
(coordinates-in-window-p (car event) (selected-window))))
(if (consp relative-coordinate)
(progn
(move-to-window-line (car (cdr relative-coordinate)))
(move-to-column (+ (car relative-coordinate) (current-column)))
(delete-char 1 nil)))))
(defun mouse-kill-line (event)
"Kill the line pointed to by the mouse."
(interactive "@e")
(let ((relative-coordinate
(coordinates-in-window-p (car event) (selected-window))))
(if (consp relative-coordinate)
(progn
(move-to-window-line (car (cdr relative-coordinate)))
(move-to-column (+ (car relative-coordinate) (current-column)))
(kill-line nil)))))
(defun narrow-window-to-region (m n)
"Narrow window to region between point and last mark"
(interactive "r")
(save-excursion
(save-restriction
(if (eq (selected-window) (next-window))
(split-window))
(goto-char m)
(recenter 0)
(if (eq (selected-window)
(if (zerop (minibuffer-depth))
(next-window)))
()
(shrink-window (- (- (window-height) (count-lines m n)) 1))))))
(defun mouse-window-to-region (event)
"Narrow window to region between cursor and mouse pointer."
(interactive "@e")
(let ((point-save (point)))
(unwind-protect
(progn (mouse-set-point event)
(push-mark nil t)
(sit-for 1))
(goto-char point-save)
(narrow-window-to-region (region-beginning) (region-end)))))
(defun mouse-ignore ()
"Don't do anything."
(interactive))
;; Commands for the scroll bar.
@ -231,77 +156,77 @@ The text before the mouse position, on the same line, is used as the prefix."
;; Set up these commands, including the prefix keys for the scroll bar.
(fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
(define-key global-mouse-map mouse-vertical-scroll-bar-prefix
'mouse-vertical-scroll-bar-prefix)
(defun mouse-scroll-motion (event)
(interactive "e")
(let ((pos (car (car event)))
(length (car (cdr (car event)))))
(message "[%d %d]" pos length)))
(let ((map (function mouse-vertical-scroll-bar-prefix)))
(define-key map mouse-button-right 'mouse-scroll-down)
(define-key map mouse-button-left 'mouse-scroll-up)
(define-key map mouse-button-middle 'mouse-scroll-absolute)
(define-key map mouse-motion 'x-horizontal-line))
;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
;(define-key global-mouse-map mouse-vertical-slider-prefix
; 'mouse-vertical-slider-prefix)
;(let ((map (function mouse-vertical-slider-prefix)))
; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
(fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
(define-key global-mouse-map mouse-vertical-thumbup-prefix
'mouse-vertical-thumbup-prefix)
(let ((map (function mouse-vertical-thumbup-prefix)))
(define-key map mouse-button-right 'mouse-scroll-down-full)
(define-key map mouse-button-left 'mouse-scroll-down-full)
(define-key map mouse-button-middle 'mouse-scroll-down-full))
(fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
(define-key global-mouse-map mouse-vertical-thumbdown-prefix
'mouse-vertical-thumbdown-prefix)
(let ((map (function mouse-vertical-thumbdown-prefix)))
(define-key map mouse-button-right 'mouse-scroll-up-full)
(define-key map mouse-button-left 'mouse-scroll-up-full)
(define-key map mouse-button-middle 'mouse-scroll-up-full))
;; Horizontal bar
(fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
(define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
'mouse-horizontal-scroll-bar-prefix)
(let ((map (function mouse-horizontal-scroll-bar-prefix)))
(define-key map mouse-button-right 'mouse-scroll-right)
(define-key map mouse-button-left 'mouse-scroll-left)
(define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
(fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
(define-key global-mouse-map mouse-horizontal-thumbleft-prefix
'mouse-horizontal-thumbleft-prefix)
(let ((map (function mouse-horizontal-thumbleft-prefix)))
(define-key map mouse-button-right 'mouse-scroll-left-full)
(define-key map mouse-button-left 'mouse-scroll-left-full)
(define-key map mouse-button-middle 'mouse-scroll-left-full))
(fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
(define-key global-mouse-map mouse-horizontal-thumbright-prefix
'mouse-horizontal-thumbright-prefix)
(let ((map (function mouse-horizontal-thumbright-prefix)))
(define-key map mouse-button-right 'mouse-scroll-right-full)
(define-key map mouse-button-left 'mouse-scroll-right-full)
(define-key map mouse-button-middle 'mouse-scroll-right-full))
;;; (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
;;; 'mouse-vertical-scroll-bar-prefix)
;;;
;;; (defun mouse-scroll-motion (event)
;;; (interactive "e")
;;; (let ((pos (car (car event)))
;;; (length (car (cdr (car event)))))
;;; (message "[%d %d]" pos length)))
;;;
;;; (let ((map (function mouse-vertical-scroll-bar-prefix)))
;;; (define-key map mouse-button-right 'mouse-scroll-down)
;;; (define-key map mouse-button-left 'mouse-scroll-up)
;;; (define-key map mouse-button-middle 'mouse-scroll-absolute)
;;; (define-key map mouse-motion 'x-horizontal-line))
;;;
;;; ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
;;; ;(define-key global-mouse-map mouse-vertical-slider-prefix
;;; ; 'mouse-vertical-slider-prefix)
;;;
;;; ;(let ((map (function mouse-vertical-slider-prefix)))
;;; ; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
;;; ; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
;;; ; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
;;;
;;; (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-vertical-thumbup-prefix
;;; 'mouse-vertical-thumbup-prefix)
;;;
;;; (let ((map (function mouse-vertical-thumbup-prefix)))
;;; (define-key map mouse-button-right 'mouse-scroll-down-full)
;;; (define-key map mouse-button-left 'mouse-scroll-down-full)
;;; (define-key map mouse-button-middle 'mouse-scroll-down-full))
;;;
;;; (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-vertical-thumbdown-prefix
;;; 'mouse-vertical-thumbdown-prefix)
;;;
;;; (let ((map (function mouse-vertical-thumbdown-prefix)))
;;; (define-key map mouse-button-right 'mouse-scroll-up-full)
;;; (define-key map mouse-button-left 'mouse-scroll-up-full)
;;; (define-key map mouse-button-middle 'mouse-scroll-up-full))
;;;
;;; ;; Horizontal bar
;;;
;;; (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
;;; 'mouse-horizontal-scroll-bar-prefix)
;;;
;;; (let ((map (function mouse-horizontal-scroll-bar-prefix)))
;;; (define-key map mouse-button-right 'mouse-scroll-right)
;;; (define-key map mouse-button-left 'mouse-scroll-left)
;;; (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
;;;
;;; (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
;;; 'mouse-horizontal-thumbleft-prefix)
;;;
;;; (let ((map (function mouse-horizontal-thumbleft-prefix)))
;;; (define-key map mouse-button-right 'mouse-scroll-left-full)
;;; (define-key map mouse-button-left 'mouse-scroll-left-full)
;;; (define-key map mouse-button-middle 'mouse-scroll-left-full))
;;;
;;; (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
;;; (define-key global-mouse-map mouse-horizontal-thumbright-prefix
;;; 'mouse-horizontal-thumbright-prefix)
;;;
;;; (let ((map (function mouse-horizontal-thumbright-prefix)))
;;; (define-key map mouse-button-right 'mouse-scroll-right-full)
;;; (define-key map mouse-button-left 'mouse-scroll-right-full)
;;; (define-key map mouse-button-middle 'mouse-scroll-right-full))
;;;;
@ -402,10 +327,10 @@ The text before the mouse position, on the same line, is used as the prefix."
(x-erase-rectangle (selected-screen))
(setq last-line-drawn nil))))
(defun test-x-rectangle ()
(use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
(define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
(define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
;;; (defun test-x-rectangle ()
;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
;;
;; Here is how to do double clicking in lisp. About to change.
@ -433,10 +358,10 @@ The text before the mouse position, on the same line, is used as the prefix."
(> (- (nth 4 event ) double-start) double-click-interval)
(setq double-start nil)))
(defun x-test-doubleclick ()
(use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
(define-key doubleclick-test-map mouse-button-left 'double-down)
(define-key doubleclick-test-map mouse-button-left-up 'double-up))
;;; (defun x-test-doubleclick ()
;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
;;; (define-key doubleclick-test-map mouse-button-left 'double-down)
;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up))
;;
;; This scrolls while button is depressed. Use preferable in scrollbar.
@ -467,12 +392,12 @@ The text before the mouse position, on the same line, is used as the prefix."
(setq scrolled-lines 0)
(sleep-for 1))
(defun x-testing-scroll ()
(let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
(define-key scrolling-map mouse-button-left 'incr-scroll-down)
(define-key scrolling-map mouse-button-right 'incr-scroll-up)
(define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
(define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
;;; (defun x-testing-scroll ()
;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down)
;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up)
;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
;;
;; Some playthings suitable for picture mode? They need work.
@ -522,3 +447,10 @@ The text before the mouse position, on the same line, is used as the prefix."
(mouse-multiple-insert
(- (car relative-coordinate) (current-column)) " "))
((= (current-column) (car relative-coordinate)) (ding))))))
;;; Bindings for mouse commands.
(global-set-key [mouse-1] 'mouse-set-point)
(global-set-key [S-mouse-1] 'mouse-set-mark)
(global-set-key [mouse-3] 'mouse-delete-other-windows)

96
lisp/term/news.el
View File

@ -18,68 +18,38 @@
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;; This file effects a mapping from the raw escape sequences of various
;; keypad and function keys to the symbols used by emacs to represent
;; those keys. The mapping from key symbol to the function performed
;; when that key is pressed is handled keyboard-independently by the file
;; ../keypad.el.
;; This file places entries in function-key-map for the raw escape
;; sequences of various keypad and function keys, binding them to
;; their symbolic forms.
;; Note that his file is also used under X11. For this to work, the variable
;; names must not change from keyboard file to keyboard file, nor can the
;; structure of keypad-maps change.
(define-prefix-command 'news-fkey-prefix 'news-fkey-map)
(define-key function-key-map "\eO" 'news-fkey-prefix)
(require 'keypad)
(defvar keypads nil
"Keypad and function keys keymap for Sony News machine.")
(defvar keypad-maps nil
"A list of strings sent by the keypad and function keys on the Sony News.
There is an element for each unique prefix. Each element is of the form
(PREFIX map map ...), each map being (string . symbol).")
(setq keypad-maps '(("\eO"
("P" . function-1)
("Q" . function-2)
("R" . function-3)
("S" . function-4)
("T" . function-5)
("U" . function-6)
("V" . function-7)
("W" . function-8)
("X" . function-9)
("Y" . function-10)
("m" . keypad-subtract)
("k" . keypad-add)
("l" . keypad-comma)
("n" . keypad-period)
("M" . keypad-enter)
("p" . keypad-0)
("q" . keypad-1)
("r" . keypad-2)
("s" . keypad-3)
("t" . keypad-4)
("u" . keypad-5)
("v" . keypad-6)
("w" . keypad-7)
("x" . keypad-8)
("y" . keypad-9)
; These three strings are just made up.
("a" . execute) ; enter
("b" . select) ; nfer
("c" . cancel)))) ; xfer
(let ((pads keypad-maps))
(while pads
(unwind-protect
(let* ((prefix (car (car pads)))
(stringmap (cdr (car pads)))
(padmap (if (lookup-key global-map prefix)
(error "Keymap entry for keypad prefix already exisists")
(make-sparse-keymap))))
(define-key global-map prefix padmap)
(setup-terminal-keymap padmap stringmap))
(setq pads (cdr pads)))))
(define-key news-fkey-map "P" [f1])
(define-key news-fkey-map "Q" [f2])
(define-key news-fkey-map "R" [f3])
(define-key news-fkey-map "S" [f4])
(define-key news-fkey-map "T" [f5])
(define-key news-fkey-map "U" [f6])
(define-key news-fkey-map "V" [f7])
(define-key news-fkey-map "W" [f8])
(define-key news-fkey-map "X" [f9])
(define-key news-fkey-map "Y" [f10])
(define-key news-fkey-map "m" [kp-subtract])
(define-key news-fkey-map "k" [kp-add])
(define-key news-fkey-map "l" [kp-separator])
(define-key news-fkey-map "n" [kp-period])
(define-key news-fkey-map "M" [kp-enter])
(define-key news-fkey-map "p" [kp-0])
(define-key news-fkey-map "q" [kp-1])
(define-key news-fkey-map "r" [kp-2])
(define-key news-fkey-map "s" [kp-3])
(define-key news-fkey-map "t" [kp-4])
(define-key news-fkey-map "u" [kp-5])
(define-key news-fkey-map "v" [kp-6])
(define-key news-fkey-map "w" [kp-7])
(define-key news-fkey-map "x" [kp-8])
(define-key news-fkey-map "y" [kp-9])
(define-key news-fkey-map "a" [execute])
(define-key news-fkey-map "b" [select])
(define-key news-fkey-map "c" [cancel])

199
src/keymap.c
View File

@ -64,6 +64,9 @@ Lisp_Object Vminibuffer_local_completion_map;
/* was MinibufLocalMustMatchMap */
Lisp_Object Vminibuffer_local_must_match_map;
/* Alist of minor mode variables and keymaps. */
Lisp_Object Vminor_mode_map_alist;
Lisp_Object Qkeymapp, Qkeymap;
/* A char over 0200 in a key sequence
@ -77,6 +80,8 @@ static void describe_command ();
static void describe_map ();
static void describe_alist ();
/* Keymap object support - constructors and predicates. */
DEFUN ("make-keymap", Fmake_keymap, Smake_keymap, 0, 0, 0,
"Construct and return a new keymap, of the form (keymap VECTOR . ALIST).\n\
VECTOR is a 128-element vector which holds the bindings for the ASCII\n\
@ -173,7 +178,8 @@ get_keymap_1 (object, error)
return tem;
if (error)
wrong_type_argument (Qkeymapp, object);
else return Qnil;
else
return Qnil;
}
Lisp_Object
@ -387,6 +393,8 @@ is not copied.")
return copy;
}
/* Simple Keymap mutators and accessors. */
DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 3, 0,
"Args KEYMAP, KEY, DEF. Define key sequence KEY, in KEYMAP, as DEF.\n\
KEYMAP is a keymap. KEY is a string or a vector of symbols and characters\n\
@ -558,6 +566,75 @@ append_key (key_sequence, key)
}
/* Global, local, and minor mode keymap stuff. */
/* Store a pointer to an array of the keymaps of the currently active
minor modes in *buf, and return the number of maps it contains.
This function always returns a pointer to the same buffer, and may
free or reallocate it, so if you want to keep it for a long time or
hand it out to lisp code, copy it. This procedure will be called
for every key sequence read, so the nice lispy approach (return a
new assoclist, list, what have you) for each invocation would
result in a lot of consing over time.
If we used xrealloc/xmalloc and ran out of memory, they would throw
back to the command loop, which would try to read a key sequence,
which would call this function again, resulting in an infinite
loop. Instead, we'll use realloc/malloc and silently truncate the
list, let the key sequence be read, and hope some other piece of
code signals the error. */
int
current_minor_maps (modeptr, mapptr)
Lisp_Object **modeptr, **mapptr;
{
static Lisp_Object *modes, *maps;
static int size;
int i = 0;
Lisp_Object alist, assoc, var;
for (alist = Vminor_mode_map_alist;
CONSP (alist);
alist = XCONS (alist)->cdr)
if (CONSP (assoc = XCONS (alist)->car)
&& XTYPE (var = XCONS (assoc)->car) == Lisp_Symbol
&& ! NULL (Fboundp (var))
&& ! NULL (Fsymbol_value (var)))
{
if (i >= size)
{
Lisp_Object *newmodes, *newmaps;
if (maps)
{
newmodes = (Lisp_Object *) realloc (modes, size *= 2);
newmaps = (Lisp_Object *) realloc (maps, size);
}
else
{
newmodes = (Lisp_Object *) malloc (size = 30);
newmaps = (Lisp_Object *) malloc (size);
}
if (newmaps && newmodes)
{
modes = newmodes;
maps = newmaps;
}
else
break;
}
modes[i] = var;
maps [i] = XCONS (assoc)->cdr;
i++;
}
if (modeptr) *modeptr = modes;
if (mapptr) *mapptr = maps;
return i;
}
DEFUN ("key-binding", Fkey_binding, Skey_binding, 1, 1, 0,
"Return the binding for command KEY in current keymaps.\n\
KEY is a string, a sequence of keystrokes.\n\
@ -565,22 +642,30 @@ The binding is probably a symbol with a function definition.")
(key)
Lisp_Object key;
{
register Lisp_Object map, value, value1;
map = current_buffer->keymap;
if (!NULL (map))
Lisp_Object *maps, value;
int nmaps, i;
nmaps = current_minor_maps (0, &maps);
for (i = 0; i < nmaps; i++)
if (! NULL (maps[i]))
{
value = Flookup_key (maps[i], key);
if (! NULL (value) && XTYPE (value) != Lisp_Int)
return value;
}
if (! NULL (current_buffer->keymap))
{
value = Flookup_key (map, key);
if (NULL (value))
{
value1 = Flookup_key (current_global_map, key);
if (XTYPE (value1) == Lisp_Int)
return Qnil;
return value1;
}
else if (XTYPE (value) != Lisp_Int)
value = Flookup_key (current_buffer->keymap, key);
if (! NULL (value) && XTYPE (value) != Lisp_Int)
return value;
}
return Flookup_key (current_global_map, key);
value = Flookup_key (current_global_map, key);
if (! NULL (value) && XTYPE (value) != Lisp_Int)
return value;
return Qnil;
}
DEFUN ("local-key-binding", Flocal_key_binding, Slocal_key_binding, 1, 1, 0,
@ -607,6 +692,38 @@ The binding is probably a symbol with a function definition.")
return Flookup_key (current_global_map, keys);
}
DEFUN ("minor-mode-key-binding", Fminor_mode_key_binding, Sminor_mode_key_binding, 1, 1, 0,
"Find the visible minor mode bindings of KEY.\n\
Return an alist of pairs (MODENAME . BINDING), where MODENAME is the\n\
the symbol which names the minor mode binding KEY, and BINDING is\n\
KEY's definition in that mode. In particular, if KEY has no\n\
minor-mode bindings, return nil. If the first binding is a\n\
non-prefix, all subsequent bindings will be omitted, since they would\n\
be ignored. Similarly, the list doesn't include non-prefix bindings\n\
that come after prefix bindings.")
(key)
{
Lisp_Object *modes, *maps;
int nmaps;
Lisp_Object binding;
int i, j;
nmaps = current_minor_maps (&modes, &maps);
for (i = j = 0; i < nmaps; i++)
if (! NULL (maps[i])
&& ! NULL (binding = Flookup_key (maps[i], key))
&& XTYPE (binding) != Lisp_Int)
{
if (! NULL (get_keymap_1 (binding, 0)))
maps[j++] = Fcons (modes[i], binding);
else if (j == 0)
return Fcons (Fcons (modes[i], binding), Qnil);
}
return Flist (j, maps);
}
DEFUN ("global-set-key", Fglobal_set_key, Sglobal_set_key, 2, 2,
"kSet key globally: \nCSet key %s to command: ",
"Give KEY a global binding as COMMAND.\n\
@ -729,7 +846,19 @@ DEFUN ("current-global-map", Fcurrent_global_map, Scurrent_global_map, 0, 0, 0,
{
return current_global_map;
}
DEFUN ("current-minor-mode-maps", Fcurrent_minor_mode_maps, Scurrent_minor_mode_maps, 0, 0, 0,
"Return a list of keymaps for the minor modes of the current buffer.")
()
{
Lisp_Object *maps;
int nmaps = current_minor_maps (0, &maps);
return Flist (nmaps, maps);
}
/* Help functions for describing and documenting keymaps. */
DEFUN ("accessible-keymaps", Faccessible_keymaps, Saccessible_keymaps,
1, 1, 0,
"Find all keymaps accessible via prefix characters from KEYMAP.\n\
@ -1021,6 +1150,8 @@ Control characters turn into \"^char\", etc.")
return build_string (tem);
}
/* where-is - finding a command in a set of keymaps. */
DEFUN ("where-is-internal", Fwhere_is_internal, Swhere_is_internal, 1, 5, 0,
"Return list of keys that invoke DEFINITION in KEYMAP or KEYMAP1.\n\
If KEYMAP is nil, search only KEYMAP1.\n\
@ -1212,6 +1343,8 @@ Argument is a command definition, usually a symbol with a function definition.")
return Qnil;
}
/* describe-bindings - summarizing all the bindings in a set of keymaps. */
DEFUN ("describe-bindings", Fdescribe_bindings, Sdescribe_bindings, 0, 0, "",
"Show a list of all defined keys, and their definitions.\n\
The list is put in a buffer, which is displayed.")
@ -1236,19 +1369,41 @@ describe_buffer_bindings (descbuf)
Fset_buffer (Vstandard_output);
{
int i, nmaps;
Lisp_Object *modes, *maps;
nmaps = current_minor_maps (&modes, &maps);
for (i = 0; i < nmaps; i++)
{
if (XTYPE (modes[i]) == Lisp_Symbol)
{
insert_char ('`');
insert_string (XSYMBOL (modes[i])->name->data);
insert_char ('\'');
}
else
insert_string ("Strangely Named");
insert_string (" Minor Mode Bindings:\n");
insert_string (heading);
describe_map_tree (maps[i], 0, Qnil);
insert_char ('\n');
}
}
start1 = XBUFFER (descbuf)->keymap;
if (!NULL (start1))
{
insert_string ("Local Bindings:\n");
insert_string (heading);
describe_map_tree (start1, 0, Qnil, Qnil);
describe_map_tree (start1, 0, Qnil);
insert_string ("\n");
}
insert_string ("Global Bindings:\n");
insert_string (heading);
describe_map_tree (current_global_map, 0, XBUFFER (descbuf)->keymap, Qnil);
describe_map_tree (current_global_map, 0, XBUFFER (descbuf)->keymap);
Fset_buffer (descbuf);
return Qnil;
@ -1563,7 +1718,7 @@ describe_vector (vector, elt_prefix, elt_describer, partial, shadow)
UNGCPRO;
}
/* Apropos */
/* Apropos - finding all symbols whose names match a regexp. */
Lisp_Object apropos_predicate;
Lisp_Object apropos_accumulate;
@ -1639,6 +1794,14 @@ syms_of_keymap ()
current_global_map = global_map;
DEFVAR_LISP ("minor-mode-map-alist", &Vminor_mode_map_alist,
"Alist of keymaps to use for minor modes.\n\
Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read\n\
key sequences and look up bindings iff VARIABLE's value is non-nil.\n\
If two active keymaps bind the same key, the keymap appearing earlier\n\
in the list takes precedence.");
Vminor_mode_map_alist = Qnil;
Qsingle_key_description = intern ("single-key-description");
staticpro (&Qsingle_key_description);
@ -1655,6 +1818,7 @@ syms_of_keymap ()
defsubr (&Skey_binding);
defsubr (&Slocal_key_binding);
defsubr (&Sglobal_key_binding);
defsubr (&Sminor_mode_key_binding);
defsubr (&Sglobal_set_key);
defsubr (&Slocal_set_key);
defsubr (&Sdefine_key);
@ -1666,6 +1830,7 @@ syms_of_keymap ()
defsubr (&Suse_local_map);
defsubr (&Scurrent_local_map);
defsubr (&Scurrent_global_map);
defsubr (&Scurrent_minor_mode_maps);
defsubr (&Saccessible_keymaps);
defsubr (&Skey_description);
defsubr (&Sdescribe_vector);